diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..5af1b5b --- /dev/null +++ b/Makefile @@ -0,0 +1,262 @@ +############################################################################# +# Configuration section +############################################################################# + +-include Makefile.config + +############################################################################## +# Variables +############################################################################## +TOP:=$(shell pwd) + +SRC=find_source.ml + +TARGET=pfff + +#------------------------------------------------------------------------------ +# Program related variables +#------------------------------------------------------------------------------ + +PROGS=pfff + +#PROGS+=pfff_test + +OPTPROGS= $(PROGS:=.opt) + +#------------------------------------------------------------------------------ +#package dependencies +#------------------------------------------------------------------------------ + +#format: XXXDIR, XXXCMD, XXXCMDOPT, XXXINCLUDE (if different XXXDIR), XXXCMA +#template: +# ifeq ($(FEATURE_XXX), 1) +# XXXDIR=xxx +# XXXCMD= $(MAKE) -C xxx && $(MAKE) xxx -C commons +# XXXCMDOPT= $(MAKE) -C xxx && $(MAKE) xxx.opt -C commons +# XXXCMA=xxx/xxx.cma commons/commons_xxx.cma +# XXXSYSCMA=xxx.cma +# XXXINCLUDE=xxx +# else +# XXXCMD= +# XXXCMDOPT= +# endif + + +# should be FEATURE_OCAMLGRAPH, or should give dependencies between features + +JSONDIR=external/jsonwheel +JSONCMA=external/jsonwheel/jsonwheel.cma +#------------------------------------------------------------------------------ +# Main variables +#------------------------------------------------------------------------------ +BASICSYSLIBS=nums.cma bigarray.cma str.cma unix.cma + +# used for sgrep and other small utilities which I dont want to depend +# on too much things +BASICLIBS=commons/commons.cma \ + commons_core/commons_core.cma \ + $(JSONCMA) \ + globals/lib.cma \ + h_program-lang/lib.cma \ + lang_cpp/parsing/lib.cma \ + lang_c/parsing/lib.cma + +# commons/commons_features.cma \ + +SYSLIBS=nums.cma bigarray.cma str.cma unix.cma +SYSLIBS+=$(OCAMLCOMPILERCMA) + +# use for the other programs +LIBS= commons/commons.cma \ + commons_core/commons_core.cma \ + $(JSONCMA) \ + globals/lib.cma \ + h_files-format/lib.cma \ + h_program-lang/lib.cma \ + lang_cpp/parsing/lib.cma \ + lang_c/parsing/lib.cma \ + +MAKESUBDIRS=commons commons_core \ + $(JSONDIR) \ + globals \ + h_files-format \ + h_program-lang \ + lang_cpp/parsing \ + lang_c/parsing \ + +INCLUDEDIRS=$(MAKESUBDIRS) + +PP=-pp "cpp $(CLANG_HACK) -DFEATURE_BYTECODE=$(FEATURE_BYTECODE) -DFEATURE_CMT=$(FEATURE_CMT)" + +############################################################################## +# Generic +############################################################################## +-include $(TOP)/Makefile.common + +############################################################################## +# Top rules +############################################################################## + +.PHONY:: all clean distclean + +#note: old: was before all: rec $(EXEC) ... but can not do that cos make -j20 +#could try to compile $(EXEC) before rec. So here force sequentiality. + +all:: Makefile.config + $(MAKE) rec + $(MAKE) $(PROGS) + +opt: + $(MAKE) rec.opt + $(MAKE) $(OPTPROGS) +all.opt: opt + + +# $(MAKE) features -C commons +# $(MAKE) features.opt -C commons + +rec: + $(MAKE) -C commons + set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i all || exit 1; done + +rec.opt: + $(MAKE) all.opt -C commons + set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i all.opt || exit 1; done + +$(TARGET): $(BASICLIBS) $(OBJS) main.cmo + $(OCAMLC) $(BYTECODE_STATIC) -o $@ $(SYSLIBS) $^ + +$(TARGET).opt: $(BASICLIBS:.cma=.cmxa) $(OPTOBJS) main.cmx + $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $^ + + +$(TARGET).top: $(LIBS) $(OBJS) + $(OCAMLMKTOP) -o $@ $(SYSLIBS) threads.cma $^ + + +clean:: + rm -f $(TARGET) +clean:: + rm -f $(TARGET).top +clean:: + set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i clean; done +clean:: + rm -f *.opt + +depend:: + set -e; for i in $(MAKESUBDIRS); do echo $$i; $(MAKE) -C $$i depend; done + +Makefile.config: + @echo "Makefile.config is missing. Have you run ./configure?" + @exit 1 + + +distclean:: clean + set -e; for i in $(MAKESUBDIRS); do $(MAKE) -C $$i $@; done + rm -f .depend + rm -f Makefile.config + rm -f globals/config_pfff.ml + rm -f TAGS +# find -name ".#*1.*" | xargs rm -f + +# add -custom so dont need add e.g. ocamlbdb/ in LD_LIBRARY_PATH +CUSTOM=-custom + +static: + rm -f $(EXEC).opt $(EXEC) + $(MAKE) STATIC="-ccopt -static" $(EXEC).opt + cp $(EXEC).opt $(EXEC) + +purebytecode: + rm -f $(EXEC).opt $(EXEC) + $(MAKE) BYTECODE_STATIC="" $(EXEC) + +#------------------------------------------------------------------------------ +# codegraph (was pm_depend) +#------------------------------------------------------------------------------ + +pfff_test: $(LIBS) $(OBJS) main_test.cmo + $(OCAMLC) $(CUSTOM) -o $@ $(SYSLIBS) $^ +pfff_test.opt: $(LIBS:.cma=.cmxa) $(OPTOBJS) main_test.cmx + $(OCAMLOPT) $(STATIC) -o $@ $(SYSLIBS:.cma=.cmxa) $^ +clean:: + rm -f pfff_test + +tests: + $(MAKE) rec && $(MAKE) pfff_test + ./pfff_test -verbose all +test: + make tests + +############################################################################## +# Build documentation +############################################################################## +.PHONY:: docs + +############################################################################## +# Install +############################################################################## + +VERSION=$(shell cat globals/config_pfff.ml.in |grep version |perl -p -e 's/.*"(.*)".*/$$1/;') + +# note: don't remove DESTDIR, it can be set by package build system like ebuild +install: all + mkdir -p $(DESTDIR)$(BINDIR) + mkdir -p $(DESTDIR)$(SHAREDIR) + cp -a $(PROGS) $(DESTDIR)$(BINDIR) + cp -a data $(DESTDIR)$(SHAREDIR) + @echo "" + @echo "You can also install pfff by copying the programs" + @echo "available in this directory anywhere you want and" + @echo "give it the right options to find its configuration files." + +uninstall: + rm -rf $(DESTDIR)$(SHAREDIR)/data + + +INSTALL_SUBDIRS= \ + commons \ + lang_cpp/parsing + +LIBNAME=pfff +install-findlib:: all all.opt + ocamlfind install $(LIBNAME) META + set -e; for i in $(INSTALL_SUBDIRS); do echo $$i; $(MAKE) -C $$i install-findlib; done + +uninstall-findlib:: + set -e; for i in $(INSTALL_SUBDIRS); do echo $$i; $(MAKE) -C $$i uninstall-findlib; done + +version: + @echo $(VERSION) + + +install-bin: + cp $(PROGS) ../pfff-binaries/mac + +############################################################################## +# Package rules +############################################################################## + +PACKAGE=$(TARGET)-$(VERSION) +TMP=/tmp + +package: + make srctar + +srctar: + make clean + cp -a . $(TMP)/$(PACKAGE) + cd $(TMP); tar cvfz $(PACKAGE).tgz --exclude=CVS --exclude=_darcs $(PACKAGE) + rm -rf $(TMP)/$(PACKAGE) + +#todo? automatically build binaries for Linux, Windows, etc? +#http://stackoverflow.com/questions/2689813/cross-compile-windows-64-bit-exe-from-linux + +# making an OPAM package: +# - git push from pfff to github +# - make a new release on github: https://github.com/facebook/pfff/releases +# - get md5sum of new archive +# - update opam file in opam-repository/pfff-xxx/ +# - test locally? +# - commit, git push +# - do pull request on github diff --git a/Makefile.common b/Makefile.common new file mode 100644 index 0000000..058869f --- /dev/null +++ b/Makefile.common @@ -0,0 +1,170 @@ +# -*- makefile -*- + +############################################################################## +# Prelude +############################################################################## + +# This file assumes the "includer" has set a few variables and then has done a +# include Makefile.common. Here are those variables: +# - TOP +# - SRC +# - INCLUDEDIRS + +# For literate programming, it also assumes a few variables: +# - SRCNW +# - TEXMAIN +# - TEX + +# For (un)installation, it assumes: +# - LIBNAME + +# this can set extra flags like -bin-annot that we want to be everywhere +-include $(TOP)/Makefile.config +# this can set extra flags like -warn-error +-include $(TOP)/Makefile.user + +############################################################################## +# Generic variables +############################################################################## + +INCLUDES?=$(INCLUDEDIRS:%=-I %) $(SYSINCLUDES) + +OBJS?= $(SRC:.ml=.cmo) +OPTOBJS?= $(SRC:.ml=.cmx) + + +############################################################################## +# Generic ocaml variables +############################################################################## + +#dont use -custom, it makes the bytecode unportable. + +#-4 allow | _ patterns in match +#-6 allow omit labels +#-29 alow multiline strings +#-45 allow shadowing open (TODO: fix them though) +#-41 allow ambiguous constructor in 2 opned modules (TODO: fix them though) +#-44 allow shadow module identifier (TODO: fix them) +#-48 allow eliminating optional arguments, unclear how to fix without wide +# changes +ifeq "$(wildcard $(TOP)/.git)" "" +WARNING_FLAGS?=-w +A-4-29-6-45-41-44-48 +else +WARNING_FLAGS?=-w +A-4-29-6-45-41-44-48 +endif + +OCAMLCFLAGS=-g -thread -dtypes $(WARNING_FLAGS) $(OCAMLCFLAGS_EXTRA) + +# This flag is also used in subdirectories so don't change its name here +# the -w y is to silence errors on the visitor_xxx files with the unused +# variable false positive +OPTFLAGS?=-thread -g -w y + +OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(PP) $(INCLUDES) +OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(PP) $(INCLUDES) +OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower +OCAMLYACC=ocamlyacc -v +OCAMLDEP=ocamldep $(PP) $(INCLUDES) +OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES) -thread + +# can also be set via 'make static' +STATIC= #-ccopt -static + +# can also be unset via 'make purebytecode' +BYTECODE_STATIC=-custom + +############################################################################## +# Top rules +############################################################################## +all:: + +############################################################################## +# Generic Literate programming variables +############################################################################## + +SYNCFLAGS=-md5sum_in_auxfile -less_marks + +SYNCWEB=~/github/syncweb/syncweb $(SYNCFLAGS) +NOWEB=~/github/syncweb/scripts/noweblatex +OCAMLDOC=ocamldoc $(INCLUDES) + +PDFLATEX=pdflatex --shell-escape + +lpclean:: + rm -f *.aux *.toc *.log *.brf *.out + +############################################################################## +# Developer rules +############################################################################## + +#old: otags -no-mli-tags -r . but does not work very well +# better to use my own tagger :) +otags: + echo "you should use pfff_tags" + +ovisual: + echo "you should use pfff_visual" + +distclean:: + rm -f TAGS + +DOTCOLORS=green,darkgoldenrod2,cyan,red,magenta,yellow,burlywood1,aquamarine,purple,lightpink,salmon,mediumturquoise,black,slategray3 + +dot: + $(OCAMLDOC) -I +threads $(SRC) -dot -dot-reduce \ + -dot-colors $(DOTCOLORS) + dot -Tps ocamldoc.out > dot.ps + mv dot.ps Fig_graph_ml.ps + ps2pdf Fig_graph_ml.ps + rm -f Fig_graph_ml.ps + +doti: + $(OCAMLDOC) -I +threads $(SRC:.ml=.mli) -dot + dot -Tps ocamldoc.out > dot.ps + mv dot.ps Fig_graph_mli.ps + ps2pdf Fig_graph_mli.ps + rm -f Fig_graph_mli.ps + +############################################################################## +# Install +############################################################################## + +uninstall-findlib:: + ocamlfind remove $(LIBNAME) + +reinstall-findlib: + $(MAKE) uninstall-findlib + $(MAKE) install-findlib + +############################################################################## +# Generic ocaml rules +############################################################################## + +.SUFFIXES: .ml .mli .cmo .cmi .cmx .cmt + +.ml.cmo: + $(OCAMLC) -c $< +.mli.cmi: + $(OCAMLC) -c $< +.ml.cmx: + $(OCAMLOPT) -c $< + +.ml.mldepend: + $(OCAMLC) -i $< + +clean:: + rm -f *.cm[ioxa] *.cmt* *.o *.a *.cmxa *.annot + rm -f *~ .*~ *.exe gmon.out #*# + +clean:: + rm -f *.aux *.toc *.log *.brf *.out + +distclean:: + rm -f .depend + +beforedepend:: + +depend:: beforedepend + $(OCAMLDEP) *.mli *.ml > .depend + +-include .depend diff --git a/Makefile.config b/Makefile.config new file mode 100644 index 0000000..992d42a --- /dev/null +++ b/Makefile.config @@ -0,0 +1,24 @@ +# autogenerated by configure + +# Where to install the binary +BINDIR=/usr/local/bin + +# Where to install the man pages +MANDIR=/usr/local/man + +# Where to install the lib +LIBDIR=/usr/local/lib + +# Where to install the configuration files +SHAREDIR=/usr/local/share/pfff + +# Features +FEATURE_VISUAL=1 +FEATURE_FACEBOOK=0 + +FEATURE_BYTECODE=1 +FEATURE_CMT=0 + +OPTBIN=.opt +OCAMLCFLAGS_EXTRA=-bin-annot -absname +OCAMLVERSION=4050 diff --git a/commons/.depend b/commons/.depend new file mode 100644 index 0000000..650f0b1 --- /dev/null +++ b/commons/.depend @@ -0,0 +1,26 @@ +common.cmo : common.cmi +common.cmx : common.cmi +common.cmi : +common2.cmo : common.cmi common2.cmi +common2.cmx : common.cmx common2.cmi +common2.cmi : common.cmi +dumper.cmo : dumper.cmi +dumper.cmx : dumper.cmi +dumper.cmi : +features.cmo : +features.cmx : +file_type.cmo : common2.cmi common.cmi file_type.cmi +file_type.cmx : common2.cmx common.cmx file_type.cmi +file_type.cmi : common.cmi +map_.cmo : map_.cmi +map_.cmx : map_.cmi +map_.cmi : +oUnit.cmo : dumper.cmi oUnit.cmi +oUnit.cmx : dumper.cmx oUnit.cmi +oUnit.cmi : +ocaml.cmo : common2.cmi common.cmi ocaml.cmi +ocaml.cmx : common2.cmx common.cmx ocaml.cmi +ocaml.cmi : common.cmi +set_.cmo : set_.cmi +set_.cmx : set_.cmi +set_.cmi : diff --git a/commons/META b/commons/META new file mode 100644 index 0000000..0d16a76 --- /dev/null +++ b/commons/META @@ -0,0 +1,4 @@ +description = "Generic functions from pfff. Yet another extended stdlib." +requires = "unix num" +archive(byte) = "commons.cma" +archive(native) = "commons.cmxa" diff --git a/commons/Makefile b/commons/Makefile new file mode 100644 index 0000000..f9f3407 --- /dev/null +++ b/commons/Makefile @@ -0,0 +1,57 @@ +############################################################################## +# Variables +############################################################################## + +# if part of pfff/ or other programs with a Makefile.config +-include ../Makefile.config + +LIBNAME=commons + +# note: if you add a file (a .mli or .ml), dont forget to redo a 'make depend' +SRC=common.ml common2.ml \ + ocaml.ml\ + file_type.ml\ + set_.ml map_.ml \ + dumper.ml oUnit.ml + +EXPORTSRC=$(SRC:%.ml=%.mli) + +OCAMLMKLIB=ocamlc -a +OCAMLMKLIBOPT=ocamlopt -a +#ocamlmklib, does some weird things when you actually dont have C code + +SYSLIBS=unix.cma str.cma + +-include Makefile.common + +# too many code in pfff assume commons/lib.cma +all:: lib.cma +all.opt: lib.cmxa lib.a + +lib.cma: $(LIBNAME).cma + cp $^ $@ +lib.cmxa: $(LIBNAME).cmxa + cp $^ $@ +lib.a: $(LIBNAME).a + cp $^ $@ + +############################################################################## +# Developer rules +############################################################################## + +clean:: + rm -f gmon.out + +forprofiling: + $(MAKE) OPTFLAGS="-p -inline 0 " opt + +# obsolete, use codegraph instead! +dependencygraph: + ocamldep *.mli *.ml > /tmp/dependfull.depend + ocamldot -fullgraph /tmp/dependfull.depend > /tmp/dependfull.dot + dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps + +dependencygraph2: + find -name "*.ml" |grep -v "scripts" | xargs ocamldep -I commons -I globals -I ctl -I parsing_cocci -I parsing_c -I engine -I popl -I extra > /tmp/dependfull.depend + ocamldot -fullgraph /tmp/dependfull.depend > /tmp/dependfull.dot + dot -Tps /tmp/dependfull.dot > /tmp/dependfull.ps diff --git a/commons/Makefile.common b/commons/Makefile.common new file mode 100644 index 0000000..134dbac --- /dev/null +++ b/commons/Makefile.common @@ -0,0 +1,118 @@ +# -*- Makefile -*- +############################################################################## +# Generic variables +############################################################################## + +OBJS = $(SRC:.ml=.cmo) +OPTOBJS = $(SRC:.ml=.cmx) + +INCLUDES=$(INCLUDEDIRS:%=-I %) $(INCLUDESEXTRA) + +LIB=$(LIBNAME).cma +OPTLIB=$(LIB:.cma=.cmxa) + +############################################################################## +# Generic OCaml variables +############################################################################## + +# This flag can also be used in subdirectories so don't change its name here. +# For profiling use: -p -inline 0 +OPTFLAGS=-thread + +# The OPTBIN variable is here to allow to use ocamlc.opt instead of +# ocaml, when it is available, which speeds up compilation. So +# if you want the fast version of the ocaml chain tools, set this var +# or setenv it to ".opt" in your startup script. +OPTBIN ?= #.opt + +# coupling: ../Makefile.common, but want independent commons/ +OCAMLCFLAGS ?= -g -dtypes $(OCAMLCFLAGS_EXTRA) -thread -w +9 + +# The OCaml tools. +OCAMLC =ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES) +OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES) +OCAMLLEX = ocamllex$(OPTBIN) +OCAMLYACC= ocamlyacc -v +OCAMLDEP = ocamldep$(OPTBIN) $(INCLUDES) +OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES) + +OCAMLMKLIB ?= ocamlmklib +CC=gcc + +############################################################################## +# Top rules +############################################################################## + + +all:: $(LIB) +all.opt: $(OPTLIB) +opt: all.opt +top: $(LIBNAME).top + +$(LIB): $(OBJS) $(COBJS) + $(OCAMLMKLIB) -o $(LIBNAME).cma $(BUILTINLIBS) $^ + +$(OPTLIB): $(OPTOBJS) $(COBJS) + $(OCAMLMKLIBOPT) -o $(LIBNAME).cmxa $(BUILTINLIBSOPT) $^ + +$(LIBNAME).top: $(OBJS) + $(OCAMLMKTOP) -o $@ $(SYSLIBS) $^ + +clean:: + rm -f $(LIBNAME).top + +############################################################################## +# Generic rules +############################################################################## + +.SUFFIXES: +.SUFFIXES: .ml .mli .cmo .cmi .cmx + +.ml.cmo: + $(OCAMLC) -c $< +.mli.cmi: + $(OCAMLC) -c $< +.ml.cmx: + $(OCAMLOPT) -c $< + +clean:: + rm -f *.cm[iox] *.o *.a *.cma *.cmxa *.annot *.cmt *.cmti *.so + rm -f *~ .*~ #*# + +clean:: + for i in $(SUBDIRS); do (cd $$i; \ + rm -f *.cm[iox] *.cmt* *.o *.a *.cma *.cmxa *.annot *~ .*~ ; \ + cd ..; ) \ + done + +depend: + $(OCAMLDEP) *.mli *.ml > .depend + for i in $(SUBDIRS); do $(OCAMLDEP) $$i/*.ml $$i/*.mli >> .depend; done + +distclean:: + rm -f .depend + +-include .depend + +############################################################################## +# install +############################################################################## + +OCAMLSTDLIB=`ocamlc -where` +install: all all.opt + mkdir -p $(OCAMLSTDLIB)/$(LIBNAME) + cp $(LIBNAME).cma $(LIBNAME).cmxa \ + common.mli ocaml.mli \ + $(OCAMLSTDLIB)/$(LIBNAME) + +install-findlib: all all.opt + ocamlfind install $(LIBNAME) META \ + $(LIBNAME).cma $(LIBNAME).cmxa $(LIBNAME).a *.cmi $(EXPORTSRC) + +uninstall-findlib: + ocamlfind remove $(LIBNAME) + +# note that the dlllib.so will be added in lib/stublibs/ +# dlllib.so lib.a liblib.a \ +# dlllib.so liblib.a\ +#todo: $(EXPORTSRC:%.mli=%.cmt) but must be guarded by having bin-annot diff --git a/commons/authors.txt b/commons/authors.txt new file mode 100644 index 0000000..5775c11 --- /dev/null +++ b/commons/authors.txt @@ -0,0 +1,6 @@ +Yoann Padioleau + +Maybe some code was borrowed from Pixel (Pascal Rigaux) +and Julia Lawall may have written a few helper functions. + +See also credits.txt. diff --git a/commons/common.ml b/commons/common.ml new file mode 100644 index 0000000..b5a7fc4 --- /dev/null +++ b/commons/common.ml @@ -0,0 +1,1324 @@ +(* Yoann Padioleau + * + * Copyright (C) 1998-2013 Yoann Padioleau + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +(*###########################################################################*) +(* Prelude *) +(*###########################################################################*) + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(* The following functions should be in their respective sections but + * because some functions in some sections use functions in other + * sections, and because I don't want to take care of the order of + * those sections, of those dependencies, I put the functions causing + * dependency problem here. C is better than OCaml on this with the + * ability to declare prototypes, enabling some form of forward + * reference. + *) + +let (+>) o f = f o + +let spf = Printf.sprintf + +exception Timeout +exception UnixExit of int + +let rec drop n xs = + match (n,xs) with + | (0,_) -> xs + | (_,[]) -> failwith "drop: not enough" + | (n,x::xs) -> drop (n-1) xs + +let take n xs = + let rec next n xs acc = + match (n,xs) with + | (0,_) -> List.rev acc + | (_,[]) -> failwith "Common.take: not enough" + | (n,x::xs) -> next (n-1) xs (x::acc) in + next n xs [] + +let rec enum_orig x n = + if x = n then [n] else x::enum_orig (x+1) n + +let enum x n = + if not(x <= n) + then failwith (Printf.sprintf "bad values in enum, expect %d <= %d" x n); + let rec enum_aux acc x n = + if x = n then n::acc else enum_aux (x::acc) (x+1) n + in + List.rev (enum_aux [] x n) + +let push v l = + l := v :: !l + + +let debugger = ref false + +let unwind_protect f cleanup = + if !debugger then f () else + try f () + with e -> begin cleanup e; raise e end + +let finalize f cleanup = + (* bug: we can not just call f in debugger mode because + * this change the semantic of the program. I originally + * put this code below: + * if !debugger then f () else + * because I wanted some errors to pop-out to the top so I can + * debug them but because now I use save_excursion and finalize + * quite a lot this changes too much the semantic. + * TODO: maybe I should not use save_excursion so much ? maybe + * -debugger helps see code that I should refactor ? + *) + try + let res = f () in + cleanup (); + res + with e -> + cleanup (); + raise e + + +let (unlines: string list -> string) = fun s -> + (String.concat "\n" s) ^ "\n" + +let (lines: string -> string list) = fun s -> + let rec lines_aux = function + | [] -> [] + | [x] -> if x = "" then [] else [x] + | x::xs -> + x::lines_aux xs + in + Str.split_delim (Str.regexp "\n") s +> lines_aux + +let save_excursion reference newv f = + let old = !reference in + reference := newv; + finalize f (fun _ -> reference := old;) + +let memoized ?(use_cache=true) h k f = + if not use_cache + then f () + else + try Hashtbl.find h k + with Not_found -> + let v = f () in + begin + Hashtbl.add h k v; + v + end + +exception Todo +exception Impossible + +exception Multi_found (* to be consistent with Not_found *) + +let exn_to_s exn = + Printexc.to_string exn + +(*###########################################################################*) +(* Basic features *) +(*###########################################################################*) + +(*****************************************************************************) +(* Debugging/logging *) +(*****************************************************************************) + +let pr s = + print_string s; + print_string "\n"; + flush stdout + +let pr2 s = + prerr_string s; + prerr_string "\n"; + flush stderr + +let pr_xxxxxxxxxxxxxxxxx () = + pr "-----------------------------------------------------------------------" + +let pr2_xxxxxxxxxxxxxxxxx () = + pr2 "-----------------------------------------------------------------------" + +let _already_printed = Hashtbl.create 101 +let disable_pr2_once = ref false + +let xxx_once f s = + if !disable_pr2_once then pr2 s + else + if not (Hashtbl.mem _already_printed s) + then begin + Hashtbl.add _already_printed s true; + f ("(ONCE) " ^ s); + end + +let pr2_once s = xxx_once pr2 s + + +(* start of dumper.ml *) + +(* Dump an OCaml value into a printable string. + * By Richard W.M. Jones (rich@annexia.org). + * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp + *) +open Printf +open Obj + +let rec dump2 r = + if is_int r then + string_of_int (magic r : int) + else ( (* Block. *) + let rec get_fields acc = function + | 0 -> acc + | n -> let n = n-1 in get_fields (field r n :: acc) n + in + let rec is_list r = + if is_int r then ( + if (magic r : int) = 0 then true (* [] *) + else false + ) else ( + let s = size r and t = tag r in + if t = 0 && s = 2 then is_list (field r 1) (* h :: t *) + else false + ) + in + let rec get_list r = + if is_int r then [] + else let h = field r 0 and t = get_list (field r 1) in h :: t + in + let opaque name = + (* XXX In future, print the address of value 'r'. Not possible in + * pure OCaml at the moment. + *) + "<" ^ name ^ ">" + in + + let s = size r and t = tag r in + + (* From the tag, determine the type of block. *) + if is_list r then ( (* List. *) + let fields = get_list r in + "[" ^ String.concat "; " (List.map dump2 fields) ^ "]" + ) + else if t = 0 then ( (* Tuple, array, record. *) + let fields = get_fields [] s in + "(" ^ String.concat ", " (List.map dump2 fields) ^ ")" + ) + + (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not + * clear if very large constructed values could have the same + * tag. XXX *) + else if t = lazy_tag then opaque "lazy" + else if t = closure_tag then opaque "closure" + else if t = object_tag then ( (* Object. *) + let fields = get_fields [] s in + let clasz, id, slots = + match fields with h::h'::t -> h, h', t | _ -> assert false in + (* No information on decoding the class (first field). So just print + * out the ID and the slots. + *) + "Object #" ^ dump2 id ^ + " (" ^ String.concat ", " (List.map dump2 slots) ^ ")" + ) + else if t = infix_tag then opaque "infix" + else if t = forward_tag then opaque "forward" + + else if t < no_scan_tag then ( (* Constructed value. *) + let fields = get_fields [] s in + "Tag" ^ string_of_int t ^ + " (" ^ String.concat ", " (List.map dump2 fields) ^ ")" + ) + else if t = string_tag then ( + "\"" ^ String.escaped (magic r : string) ^ "\"" + ) + else if t = double_tag then ( + string_of_float (magic r : float) + ) + else if t = abstract_tag then opaque "abstract" + else if t = custom_tag then opaque "custom" + else if t = final_tag then opaque "final" + else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")") + ) + +let dump v = dump2 (repr v) + +(* end of dumper.ml *) + +(* +let (dump : 'a -> string) = fun x -> + Dumper.dump x +*) + +let pr2_gen x = pr2 (dump x) + +(*****************************************************************************) +(* Profiling *) +(*****************************************************************************) + +type prof = ProfAll | ProfNone | ProfSome of string list +let profile = ref ProfNone +let show_trace_profile = ref false + +let check_profile category = + match !profile with + | ProfAll -> true + | ProfNone -> false + | ProfSome l -> List.mem category l + +let _profile_table = ref (Hashtbl.create 100) + +let adjust_profile_entry category difftime = + let (xtime, xcount) = + (try Hashtbl.find !_profile_table category + with Not_found -> + let xtime = ref 0.0 in + let xcount = ref 0 in + Hashtbl.add !_profile_table category (xtime, xcount); + (xtime, xcount) + ) in + xtime := !xtime +. difftime; + xcount := !xcount + 1; + () + +let profile_start category = failwith "todo" +let profile_end category = failwith "todo" + + +(* subtil: don't forget to give all argumens to f, otherwise partial app + * and will profile nothing. + * + * todo: try also detect when complexity augment each time, so can + * detect the situation for a function gets worse and worse ? + *) +let profile_code category f = + if not (check_profile category) + then f () + else begin + if !show_trace_profile then pr2 (spf "> %s" category); + let t = Unix.gettimeofday () in + let res, prefix = + try Some (f ()), "" + with Timeout -> None, "*" + in + let category = prefix ^ category in (* add a '*' to indicate timeout func *) + let t' = Unix.gettimeofday () in + + if !show_trace_profile then pr2 (spf "< %s" category); + + adjust_profile_entry category (t' -. t); + (match res with + | Some res -> res + | None -> raise Timeout + ); + end + + +let _is_in_exclusif = ref (None: string option) + +let profile_code_exclusif category f = + if not (check_profile category) + then f () + else begin + + match !_is_in_exclusif with + | Some s -> + failwith (spf "profile_code_exclusif: %s but already in %s " category s); + | None -> + _is_in_exclusif := (Some category); + finalize + (fun () -> + profile_code category f + ) + (fun () -> + _is_in_exclusif := None + ) + + end + +let profile_code_inside_exclusif_ok category f = + failwith "Todo" + + +let (with_open_stringbuf: (((string -> unit) * Buffer.t) -> unit) -> string) = + fun f -> + let buf = Buffer.create 1000 in + let pr s = Buffer.add_string buf (s ^ "\n") in + f (pr, buf); + Buffer.contents buf + + +(* todo: also put % ? also add % to see if coherent numbers *) +let profile_diagnostic () = + if !profile = ProfNone then "" else + let xs = + Hashtbl.fold (fun k v acc -> (k,v)::acc) !_profile_table [] + +> List.sort (fun (k1, (t1,n1)) (k2, (t2,n2)) -> compare t2 t1) + in + with_open_stringbuf (fun (pr,_) -> + pr "---------------------"; + pr "profiling result"; + pr "---------------------"; + xs +> List.iter (fun (k, (t,n)) -> + pr (Printf.sprintf "%-40s : %10.3f sec %10d count" k !t !n) + ) + ) + + + +let report_if_take_time timethreshold s f = + let t = Unix.gettimeofday () in + let res = f () in + let t' = Unix.gettimeofday () in + if (t' -. t > float_of_int timethreshold) + then pr2 (Printf.sprintf "Note: processing took %7.1fs: %s" (t' -. t) s); + res + +let profile_code2 category f = + profile_code category (fun () -> + if !profile = ProfAll + then pr2 ("starting: " ^ category); + let t = Unix.gettimeofday () in + let res = f () in + let t' = Unix.gettimeofday () in + if !profile = ProfAll + then pr2 (spf "ending: %s, %fs" category (t' -. t)); + res + ) + +(*****************************************************************************) +(* Test *) +(*****************************************************************************) + +(* See OUnit *) + +(*****************************************************************************) +(* Persistence *) +(*****************************************************************************) + +let get_value filename = + let chan = open_in filename in + let x = input_value chan in (* <=> Marshal.from_channel *) + (close_in chan; x) + +let write_value valu filename = + let chan = open_out filename in + (output_value chan valu; (* <=> Marshal.to_channel *) + (* Marshal.to_channel chan valu [Marshal.Closures]; *) + close_out chan) + +(*****************************************************************************) +(* Composition/Control *) +(*****************************************************************************) + +(*****************************************************************************) +(* Error managment *) +(*****************************************************************************) + +(*****************************************************************************) +(* Arguments/options and command line (cocci and acomment) *) +(*****************************************************************************) + +(* + * todo? isn't unison or scott-mcpeak-lib-in-cil handles that kind of + * stuff better ? That is the need to localize command line argument + * while still being able to gathering them. Same for logging. + * Similiar to the type prof = PALL | PNONE | PSOME of string list. + * Same spirit of fine grain config in log4j ? + * + * todo? how mercurial/cvs/git manage command line options ? because they + * all have a kind of DSL around arguments with some common options, + * specific options, conventions, etc. + * + * + * todo? generate the corresponding noxxx options ? + * todo? generate list of options and show their value ? + * + * todo? make it possible to set this value via a config file ? + * + * + *) + +type arg_spec_full = Arg.key * Arg.spec * Arg.doc +type cmdline_options = arg_spec_full list + +(* the format is a list of triples: + * (title of section * (optional) explanation of sections * options) + *) +type options_with_title = string * string * arg_spec_full list +type cmdline_sections = options_with_title list + + +(* ---------------------------------------------------------------------- *) + +(* now I use argv as I like at the call sites to show that + * this function internally use argv. + *) +let parse_options options usage_msg argv = + let args = ref [] in + (try + Arg.parse_argv argv options (fun file -> args := file::!args) usage_msg; + args := List.rev !args; + !args + with + | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2 + | Arg.Help msg -> Printf.printf "%s" msg; exit 0 + ) + + + + +let usage usage_msg options = + Arg.usage (Arg.align options) usage_msg + + +(* for coccinelle *) + +(* If you don't want the -help and --help that are appended by Arg.align *) +let arg_align2 xs = + Arg.align xs +> List.rev +> drop 2 +> List.rev + + +let short_usage usage_msg ~short_opt = + usage usage_msg short_opt + +let long_usage usage_msg ~short_opt ~long_opt = + pr usage_msg; + pr ""; + let all_options_with_title = + (("main options", "", short_opt)::long_opt) in + all_options_with_title +> List.iter + (fun (title, explanations, xs) -> + pr title; + pr_xxxxxxxxxxxxxxxxx(); + if explanations <> "" + then begin pr explanations; pr "" end; + arg_align2 xs +> List.iter (fun (key,action,s) -> + pr (" " ^ key ^ s) + ); + pr ""; + ); + () + + +(* copy paste of Arg.parse. Don't want the default -help msg *) +let arg_parse2 l msg short_usage_fun = + let args = ref [] in + let f = (fun file -> args := file::!args) in + let l = Arg.align l in + (try begin + Arg.parse_argv Sys.argv l f msg; + args := List.rev !args; + !args + end + with + | Arg.Bad msg -> (* eprintf "%s" msg; exit 2; *) + let xs = lines msg in + (* take only head, it's where the error msg is *) + pr2 (List.hd xs); + short_usage_fun(); + raise (UnixExit (2)) + | Arg.Help msg -> (* printf "%s" msg; exit 0; *) + raise Impossible (* -help is specified in speclist *) + ) + + +(* ---------------------------------------------------------------------- *) + +type flag_spec = Arg.key * Arg.spec * Arg.doc +type action_spec = Arg.key * Arg.doc * action_func + and action_func = (string list -> unit) + +type cmdline_actions = action_spec list +exception WrongNumberOfArguments + +let options_of_actions action_ref actions = + actions +> List.map (fun (key, doc, _func) -> + (key, (Arg.Unit (fun () -> action_ref := key)), doc) + ) + +let (action_list: cmdline_actions -> Arg.key list) = fun xs -> + List.map (fun (a,b,c) -> a) xs + +let (do_action: Arg.key -> string list (* args *) -> cmdline_actions -> unit) = + fun key args xs -> + let assoc = xs +> List.map (fun (a,b,c) -> (a,c)) in + let action_func = List.assoc key assoc in + action_func args + + +(* todo? if have a function with default argument ? would like a + * mk_action_0_or_1_arg ? + *) + +let mk_action_0_arg f = + (function + | [] -> f () + | _ -> raise WrongNumberOfArguments + ) + +let mk_action_1_arg f = + (function + | [file] -> f file + | _ -> raise WrongNumberOfArguments + ) + +let mk_action_2_arg f = + (function + | [file1;file2] -> f file1 file2 + | _ -> raise WrongNumberOfArguments + ) + +let mk_action_3_arg f = + (function + | [file1;file2;file3] -> f file1 file2 file3 + | _ -> raise WrongNumberOfArguments + ) + +let mk_action_4_arg f = + (function + | [file1;file2;file3;file4] -> f file1 file2 file3 file4 + | _ -> raise WrongNumberOfArguments + ) + +let mk_action_n_arg f = f + +(*****************************************************************************) +(* Equality *) +(*****************************************************************************) +let (=|=) : int -> int -> bool = (=) +let (=<=) : char -> char -> bool = (=) +let (=$=) : string -> string -> bool = (=) +let (=:=) : bool -> bool -> bool = (=) + +let (=*=) = (=) + +(*###########################################################################*) +(* Basic types *) +(*###########################################################################*) + +(*****************************************************************************) +(* Bool *) +(*****************************************************************************) + +(*****************************************************************************) +(* Char *) +(*****************************************************************************) + +(*****************************************************************************) +(* Num *) +(*****************************************************************************) + +(*****************************************************************************) +(* Tuples *) +(*****************************************************************************) + +(*****************************************************************************) +(* Maybe *) +(*****************************************************************************) + +(* type 'a maybe = Just of 'a | None *) +let (>>=) m1 m2 = + match m1 with + | None -> None + | Some x -> m2 x + +(* + (*http://roscidus.com/blog/blog/2013/10/13/ocaml-tips/#handling-option-types*) + let (|?) maybe default = + match maybe with + | Some v -> v + | None -> Lazy.force default +*) + +let map_opt f = function + | None -> None + | Some x -> Some (f x) + +let do_option f = function + | None -> () + | Some x -> f x +let opt = do_option + +(* not sure why but can't use let (?:) a b = ... then at use time ocaml yells*) +let (|||) a b = + match a with + | Some x -> x + | None -> b + +type ('a,'b) either = Left of 'a | Right of 'b + (* with sexp *) +type ('a, 'b, 'c) either3 = Left3 of 'a | Middle3 of 'b | Right3 of 'c + (* with sexp *) + + +let partition_either f l = + let rec part_either left right = function + | [] -> (List.rev left, List.rev right) + | x :: l -> + (match f x with + | Left e -> part_either (e :: left) right l + | Right e -> part_either left (e :: right) l) in + part_either [] [] l + +let partition_either3 f l = + let rec part_either left middle right = function + | [] -> (List.rev left, List.rev middle, List.rev right) + | x :: l -> + (match f x with + | Left3 e -> part_either (e :: left) middle right l + | Middle3 e -> part_either left (e :: middle) right l + | Right3 e -> part_either left middle (e :: right) l) in + part_either [] [] [] l + +let rec filter_some = function + | [] -> [] + | None :: l -> filter_some l + | Some e :: l -> e :: filter_some l + +let map_filter f xs = xs +> List.map f +> filter_some + +let rec find_some_opt p = function + | [] -> None + | x :: l -> + match p x with + | Some v -> Some v + | None -> find_some_opt p l + +let find_some p xs = + match find_some_opt p xs with + | None -> raise Not_found + | Some x -> x + +let rec find_opt f xs = + find_some_opt (fun x -> if f x then Some x else None) xs + + +(*****************************************************************************) +(* Regexp, can also use PCRE *) +(*****************************************************************************) + +let (matched: int -> string -> string) = fun i s -> + Str.matched_group i s + +let matched1 = fun s -> matched 1 s +let matched2 = fun s -> (matched 1 s, matched 2 s) +let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s) +let matched4 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s) +let matched5 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s) +let matched6 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s) +let matched7 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s, matched 7 s) + +let _memo_compiled_regexp = Hashtbl.create 101 +let candidate_match_func s re = + (* old: Str.string_match (Str.regexp re) s 0 *) + let compile_re = + memoized _memo_compiled_regexp re (fun () -> Str.regexp re) + in + Str.string_match compile_re s 0 + +let match_func s re = + profile_code "Common.=~" (fun () -> candidate_match_func s re) + +let (=~) s re = + match_func s re + +let split sep s = Str.split (Str.regexp sep) s + +let join sep xs = String.concat sep xs + +(*****************************************************************************) +(* Strings *) +(*****************************************************************************) + +(* ruby *) +let i_to_s = string_of_int +let s_to_i = int_of_string + +let null_string s = + s =$= "" + +(*****************************************************************************) +(* Filenames *) +(*****************************************************************************) + +type filename = string (* TODO could check that exist :) type sux *) + (* with sexp *) +type dirname = string (* TODO could check that exist :) type sux *) + (* with sexp *) + +(* file or dir *) +type path = string + +let chop_dirsymbol = function + | s when s =~ "\\(.*\\)/$" -> matched1 s + | s -> s + +(* pre: prj_path must not contain regexp symbol *) +let filename_without_leading_path prj_path s = + let prj_path = chop_dirsymbol prj_path in + if s =$= prj_path + then "." + else + if s =~ ("^" ^ prj_path ^ "/\\(.*\\)$") + then matched1 s + else + failwith + (spf "cant find filename_without_project_path: %s %s" prj_path s) + +let readable ~root s = + filename_without_leading_path root s + +let is_directory file = + (Unix.stat file).Unix.st_kind =*= Unix.S_DIR + +(*****************************************************************************) +(* Dates *) +(*****************************************************************************) + +(*****************************************************************************) +(* Lines/words/strings *) +(*****************************************************************************) + +(*****************************************************************************) +(* Process/Files *) +(*****************************************************************************) + +let command2 s = ignore(Sys.command s) + +exception CmdError of Unix.process_status * string + +let process_output_to_list2 ?(verbose=false) command = + let chan = Unix.open_process_in command in + let res = ref ([] : string list) in + let rec process_otl_aux () = + let e = input_line chan in + res := e::!res; + if verbose then pr2 e; + process_otl_aux() in + try process_otl_aux () + with End_of_file -> + let stat = Unix.close_process_in chan in (List.rev !res,stat) + +let cmd_to_list ?verbose command = + let (l,exit_status) = process_output_to_list2 ?verbose command in + match exit_status with + | Unix.WEXITED 0 -> l + | _ -> raise (CmdError (exit_status, + (spf "CMD = %s, RESULT = %s" + command (String.concat "\n" l)))) + +let cmd_to_list_and_status = process_output_to_list2 + + +(* tail recursive efficient version *) +let cat file = + let chan = open_in file in + let rec cat_aux acc () = + (* cant do input_line chan::aux() cos ocaml eval from right to left ! *) + let (b, l) = try (true, input_line chan) with End_of_file -> (false, "") in + if b + then cat_aux (l::acc) () + else acc + in + cat_aux [] () +> List.rev +> (fun x -> close_in chan; x) + +let read_file file = + let ic = open_in file in + let size = in_channel_length ic in + let buf = Bytes.create size in + really_input ic buf 0 size; + close_in ic; + buf + +let write_file ~file s = + let chan = open_out file in + (output_string chan s; close_out chan) + +(* could be in control section too *) + +let filemtime file = + (Unix.stat file).Unix.st_mtime + +(* +Using an external C functions complicates the linking process of +programs using commons/. Thus, I replaced realpath() with an OCaml-only +similar functions fullpath(). + +external c_realpath: string -> string option = "caml_realpath" + +let realpath2 path = + match c_realpath path with + | Some s -> s + | None -> failwith (spf "problem with realpath on %s" path) + +let realpath2 path = + let stat = Unix.stat path in + let dir, suffix = + match stat.Unix.st_kind with + | Unix.S_DIR -> path, "" + | _ -> Filename.dirname path, Filename.basename path + in + + let oldpwd = Sys.getcwd () in + Sys.chdir dir; + let realpath_dir = Sys.getcwd () in + Sys.chdir oldpwd; + Filename.concat realpath_dir suffix + +let realpath path = + profile_code "Common.realpath" (fun () -> realpath2 path) +*) + +let fullpath file = + if not (Sys.file_exists file) + then failwith (spf "fullpath: file %s does not exist" file); + let dir, base = + if Sys.is_directory file + then file, None + else Filename.dirname file, Some (Filename.basename file) + in + let old = Sys.getcwd () in + Sys.chdir dir; + let here = Sys.getcwd () in + Sys.chdir old; + match base with + | None -> here + | Some x -> Filename.concat here x + +(* Why a use_cache argument ? because sometimes want disable it but dont + * want put the cache_computation funcall in comment, so just easier to + * pass this extra option. + *) +let cache_computation2 ?(verbose=false) ?(use_cache=true) file ext_cache f = + if not use_cache + then f () + else begin + if not (Sys.file_exists file) + then begin + pr2 ("WARNING: cache_computation: can't find file " ^ file); + pr2 ("defaulting to calling the function"); + f () + end else begin + let file_cache = (file ^ ext_cache) in + if Sys.file_exists file_cache && + filemtime file_cache >= filemtime file + then begin + if verbose then pr2 ("using cache: " ^ file_cache); + get_value file_cache + end + else begin + let res = f () in + write_value res file_cache; + res + end + end + end +let cache_computation ?verbose ?use_cache a b c = + profile_code "Common.cache_computation" (fun () -> + cache_computation2 ?verbose ?use_cache a b c) + + +(* emacs/lisp inspiration (eric cooper and yaron minsky use that too) *) +let (with_open_outfile: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) = + fun file f -> + let chan = open_out file in + let pr s = output_string chan s in + unwind_protect (fun () -> + let res = f (pr, chan) in + close_out chan; + res) + (fun e -> close_out chan) + +let (with_open_infile: filename -> ((in_channel) -> 'a) -> 'a) = fun file f -> + let chan = open_in file in + unwind_protect (fun () -> + let res = f chan in + close_in chan; + res) + (fun e -> close_in chan) + +(* now in prelude: + * exception Timeout + *) + +(* it seems that the toplevel block such signals, even with this explicit + * command :( + * let _ = Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigalrm] + *) + +(* could be in Control section *) + +(* subtil: have to make sure that timeout is not intercepted before here, so + * avoid exn handle such as try (...) with _ -> cos timeout will not bubble up + * enough. In such case, add a case before such as + * with Timeout -> raise Timeout | _ -> ... + * + * question: can we have a signal and so exn when in a exn handler ? + *) +let timeout_function ?(verbose=false) timeoutval = fun f -> + try + begin + Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout )); + ignore(Unix.alarm timeoutval); + let x = f () in + ignore(Unix.alarm 0); + x + end + with Timeout -> + begin + if verbose then pr2 "timeout (we abort)"; + raise Timeout; + end + | e -> + (* subtil: important to disable the alarm before relaunching the exn, + * otherwise the alarm is still running. + * + * robust?: and if alarm launched after the log (...) ? + * Maybe signals are disabled when process an exception handler ? + *) + begin + ignore(Unix.alarm 0); + (* log ("exn while in transaction (we abort too, even if ...) = " ^ + Printexc.to_string e); + *) + if verbose then pr2 "exn while in timeout_function"; + raise e + end + +(* creation of tmp files, a la gcc *) + +let _temp_files_created = ref ([] : filename list) + +(* ex: new_temp_file "cocci" ".c" will give "/tmp/cocci-3252-434465.c" *) +let new_temp_file prefix suffix = + let processid = i_to_s (Unix.getpid ()) in + let tmp_file = Filename.temp_file (prefix ^ "-" ^ processid ^ "-") suffix in + push tmp_file _temp_files_created; + tmp_file + +let save_tmp_files = ref false +let erase_temp_files () = + if not !save_tmp_files then begin + !_temp_files_created +> List.iter (fun s -> + (* pr2 ("erasing: " ^ s); *) + command2 ("rm -f " ^ s) + ); + _temp_files_created := [] + end + +let erase_this_temp_file f = + if not !save_tmp_files then begin + _temp_files_created := + List.filter (function x -> not (x =$= f)) !_temp_files_created; + command2 ("rm -f " ^ f) + end + +(*###########################################################################*) +(* Collection-like types *) +(*###########################################################################*) + +(*****************************************************************************) +(* List *) +(*****************************************************************************) + +let exclude p xs = + List.filter (fun x -> not (p x)) xs + +let rec (span: ('a -> bool) -> 'a list -> 'a list * 'a list) = + fun p -> function + | [] -> ([], []) + | x::xs -> + if p x then + let (l1, l2) = span p xs in + (x::l1, l2) + else ([], x::xs) + +let rec take_safe n xs = + match (n,xs) with + | (0,_) -> [] + | (_,[]) -> [] + | (n,x::xs) -> x::take_safe (n-1) xs + +let group_by f xs = + (* use Hashtbl.find_all property *) + let h = Hashtbl.create 101 in + + (* could use Set *) + let hkeys = Hashtbl.create 101 in + + xs |> List.iter (fun x -> + let k = f x in + Hashtbl.replace hkeys k true; + Hashtbl.add h k x + ); + Hashtbl.fold (fun k _ acc -> (k, Hashtbl.find_all h k)::acc) hkeys [] + +let group_by_multi fkeys xs = + (* use Hashtbl.find_all property *) + let h = Hashtbl.create 101 in + + (* could use Set *) + let hkeys = Hashtbl.create 101 in + + xs |> List.iter (fun x -> + let ks = fkeys x in + ks |> List.iter (fun k -> + Hashtbl.replace hkeys k true; + Hashtbl.add h k x; + ) + ); + Hashtbl.fold (fun k _ acc -> (k, Hashtbl.find_all h k)::acc) hkeys [] + + +(* you should really use group_assoc_bykey_eff *) +let rec group_by_mapped_key fkey l = + match l with + | [] -> [] + | x::xs -> + let k = fkey x in + let (xs1,xs2) = List.partition (fun x' -> let k2 = fkey x' in k=*=k2) xs + in + (k, (x::xs1))::(group_by_mapped_key fkey xs2) + +let rec zip xs ys = + match (xs,ys) with + | ([],[]) -> [] + | ([],_) -> failwith "zip: not same length" + | (_,[]) -> failwith "zip: not same length" + | (x::xs,y::ys) -> (x,y)::zip xs ys + +let null xs = + match xs with [] -> true | _ -> false + +let index_list xs = + if null xs then [] (* enum 0 (-1) generate an exception *) + else zip xs (enum 0 ((List.length xs) -1)) + +let index_list_0 xs = index_list xs + +let index_list_1 xs = + xs +> index_list +> List.map (fun (x,i) -> x, i+1) + +let sort_prof a b = + profile_code "Common.sort_by_xxx" (fun () -> List.sort a b) + +type order = HighFirst | LowFirst +let compare_order order a b = + match order with + | HighFirst -> compare b a + | LowFirst -> compare a b + +let sort_by_val_highfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare v2 v1) xs +let sort_by_val_lowfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare v1 v2) xs + +let sort_by_key_highfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs +let sort_by_key_lowfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs + +(*****************************************************************************) +(* Assoc *) +(*****************************************************************************) +type ('a, 'b) assoc = ('a * 'b) list + +(*****************************************************************************) +(* Arrays *) +(*****************************************************************************) + +(*****************************************************************************) +(* Matrix *) +(*****************************************************************************) + +(*****************************************************************************) +(* Set. Have a look too at set*.mli *) +(*****************************************************************************) + +(*****************************************************************************) +(* Hash *) +(*****************************************************************************) + +let hash_to_list h = + Hashtbl.fold (fun k v acc -> (k,v)::acc) h [] + +> List.sort compare + +let hash_of_list xs = + let h = Hashtbl.create 101 in + xs +> List.iter (fun (k, v) -> Hashtbl.replace h k v); + h + + +(*****************************************************************************) +(* Hash sets *) +(*****************************************************************************) + +type 'a hashset = ('a, bool) Hashtbl.t + (* with sexp *) + +let hashset_to_list h = + hash_to_list h +> List.map fst + +let hashset_of_list xs = + xs +> List.map (fun x -> x, true) +> hash_of_list + +let hkeys h = + let hkey = Hashtbl.create 101 in + h +> Hashtbl.iter (fun k v -> Hashtbl.replace hkey k true); + hashset_to_list hkey + +let group_assoc_bykey_eff2 xs = + let h = Hashtbl.create 101 in + xs +> List.iter (fun (k, v) -> Hashtbl.add h k v); + let keys = hkeys h in + keys +> List.map (fun k -> k, Hashtbl.find_all h k) + +let group_assoc_bykey_eff xs = + profile_code "Common.group_assoc_bykey_eff" (fun () -> + group_assoc_bykey_eff2 xs) + +(*****************************************************************************) +(* Stack *) +(*****************************************************************************) + +type 'a stack = 'a list + (* with sexp *) + +(*****************************************************************************) +(* Tree *) +(*****************************************************************************) + +(*****************************************************************************) +(* Graph. Have a look too at Ograph_*.mli *) +(*****************************************************************************) + +(*****************************************************************************) +(* Generic op *) +(*****************************************************************************) +let sort xs = List.sort Pervasives.compare xs + +(*###########################################################################*) +(* Misc functions *) +(*###########################################################################*) + +(*###########################################################################*) +(* Postlude *) +(*###########################################################################*) + +(*****************************************************************************) +(* Flags and actions *) +(*****************************************************************************) + +(*****************************************************************************) +(* Postlude *) +(*****************************************************************************) + +(*****************************************************************************) +(* Misc *) +(*****************************************************************************) + + + +(* now in prelude: exception UnixExit of int *) +let exn_to_real_unixexit f = + try f () + with UnixExit x -> exit x + +let pp_do_in_zero_box f = Format.open_box 0; f (); Format.close_box () + + +let main_boilerplate f = + if not (!Sys.interactive) then + exn_to_real_unixexit (fun () -> + + Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> + pr2 "C-c intercepted, will do some cleaning before exiting"; + (* But if do some try ... with e -> and if do not reraise the exn, + * the bubble never goes at top and so I cant really C-c. + * + * A solution would be to not raise, but do the erase_temp_file in the + * syshandler, here, and then exit. + * The current solution is to not do some wild try ... with e + * by having in the exn handler a case: UnixExit x -> raise ... | e -> + *) + Sys.set_signal Sys.sigint Sys.Signal_default; + raise (UnixExit (-1)) + )); + + (* The finalize below makes it tedious to go back to exn when use + * 'back' in the debugger. Hence this special case. But the + * Common.debugger will be set in main(), so too late, so + * have to be quicker + *) + if Sys.argv +> Array.to_list +> List.exists (fun x -> x =$= "-debugger") + then debugger := true; + + finalize (fun ()-> + pp_do_in_zero_box (fun () -> + try + f (); (* <---- here it is *) + with Unix.Unix_error (e, fm, argm) -> + pr2 (spf "exn Unix_error: %s %s %s\n" + (Unix.error_message e) fm argm); + raise (Unix.Unix_error (e, fm, argm)) + )) + (fun()-> + if !profile <> ProfNone + then begin + pr2 (profile_diagnostic ()); + Gc.print_stat stderr; + end; + erase_temp_files (); + ) + ) +(* let _ = if not !Sys.interactive then (main ()) *) + +let follow_symlinks = ref false + +let arg_symlink () = + if !follow_symlinks + then " -L " + else "" + +let grep_dash_v_str = + "| grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/" ^ + "| grep -v /.svn/ | grep -v .git_annot | grep -v .marshall" + +let files_of_dir_or_files_no_vcs_nofilter xs = + xs +> List.map (fun x -> + if is_directory x + then + (* todo: should escape x *) + let cmd = (spf "find %s '%s' -noleaf -type f %s" + (arg_symlink()) x grep_dash_v_str) in + let (xs, status) = + cmd_to_list_and_status cmd in + (match status with + | Unix.WEXITED 0 -> xs + | _ -> raise (CmdError (status, + (spf "CMD = %s, RESULT = %s" + cmd (String.concat "\n" xs)))) + ) + else [x] + ) +> List.concat + + +(*****************************************************************************) +(* Maps *) +(*****************************************************************************) + +module SMap = Map.Make (String) +type 'a smap = 'a SMap.t diff --git a/commons/common.mli b/commons/common.mli new file mode 100644 index 0000000..3011f24 --- /dev/null +++ b/commons/common.mli @@ -0,0 +1,245 @@ + +val (+>) : 'a -> ('a -> 'b) -> 'b + +val (=|=) : int -> int -> bool +val (=<=) : char -> char -> bool +val (=$=) : string -> string -> bool +val (=:=) : bool -> bool -> bool + +val (=*=): 'a -> 'a -> bool + +val pr : string -> unit +val pr2 : string -> unit + +(* forbid pr2_once to do the once "optimisation" *) +val _already_printed : (string, bool) Hashtbl.t +val disable_pr2_once : bool ref +val pr2_once : string -> unit + +val pr2_gen: 'a -> unit +val dump: 'a -> string + +exception Todo +exception Impossible + +exception Multi_found + +val exn_to_s : exn -> string + +val i_to_s : int -> string +val s_to_i : string -> int + +val null_string : string -> bool + +val (=~) : string -> string -> bool +val matched1 : string -> string +val matched2 : string -> string * string +val matched3 : string -> string * string * string +val matched4 : string -> string * string * string * string +val matched5 : string -> string * string * string * string * string +val matched6 : string -> string * string * string * string * string * string +val matched7 : string -> string * string * string * string * string * string * string + +val spf : ('a, unit, string) format -> 'a + +val join : string (* sep *) -> string list -> string +val split : string (* sep regexp *) -> string -> string list + +type filename = string +type dirname = string +type path = string + +val cat : filename -> string list + +val write_file : file:filename -> string -> unit +val read_file : filename -> string + +val with_open_outfile : + filename -> ((string -> unit) * out_channel -> 'a) -> 'a +val with_open_infile : + filename -> (in_channel -> 'a) -> 'a + +exception CmdError of Unix.process_status * string +val command2 : string -> unit +val cmd_to_list : ?verbose:bool -> string -> string list (* alias *) +val cmd_to_list_and_status: + ?verbose:bool -> string -> string list * Unix.process_status + +val null : 'a list -> bool +val exclude : ('a -> bool) -> 'a list -> 'a list +val sort : 'a list -> 'a list + +val map_filter : ('a -> 'b option) -> 'a list -> 'b list +val find_opt: ('a -> bool) -> 'a list -> 'a option +val find_some : ('a -> 'b option) -> 'a list -> 'b +val find_some_opt : ('a -> 'b option) -> 'a list -> 'b option +val filter_some: 'a option list -> 'a list + +val take : int -> 'a list -> 'a list +val take_safe : int -> 'a list -> 'a list +val drop : int -> 'a list -> 'a list +val span : ('a -> bool) -> 'a list -> 'a list * 'a list + +val index_list : 'a list -> ('a * int) list +val index_list_0 : 'a list -> ('a * int) list +val index_list_1 : 'a list -> ('a * int) list + +type ('a, 'b) assoc = ('a * 'b) list + +val sort_by_val_lowfirst: ('a,'b) assoc -> ('a * 'b) list +val sort_by_val_highfirst: ('a,'b) assoc -> ('a * 'b) list + +val sort_by_key_lowfirst: ('a,'b) assoc -> ('a * 'b) list +val sort_by_key_highfirst: ('a,'b) assoc -> ('a * 'b) list + +val group_by: ('a -> 'b) -> 'a list -> ('b * 'a list) list +val group_assoc_bykey_eff : ('a * 'b) list -> ('a * 'b list) list +val group_by_mapped_key: ('a -> 'b) -> 'a list -> ('b * 'a list) list +val group_by_multi: ('a -> 'b list) -> 'a list -> ('b * 'a list) list + +type 'a stack = 'a list +val push : 'a -> 'a stack ref -> unit + +val hash_of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t +val hash_to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list + +type 'a hashset = ('a, bool) Hashtbl.t +val hashset_of_list : 'a list -> 'a hashset +val hashset_to_list : 'a hashset -> 'a list + +val map_opt: ('a -> 'b) -> 'a option -> 'b option +val opt: ('a -> unit) -> 'a option -> unit +val do_option : ('a -> unit) -> 'a option -> unit +val (>>=): 'a option -> ('a -> 'b option) -> 'b option +val (|||): 'a option -> 'a -> 'a + + +type ('a, 'b) either = Left of 'a | Right of 'b +type ('a, 'b, 'c) either3 = Left3 of 'a | Middle3 of 'b | Right3 of 'c +val partition_either : + ('a -> ('b, 'c) either) -> 'a list -> 'b list * 'c list +val partition_either3 : + ('a -> ('b, 'c, 'd) either3) -> 'a list -> 'b list * 'c list * 'd list + + + +type arg_spec_full = Arg.key * Arg.spec * Arg.doc +type cmdline_options = arg_spec_full list + +type options_with_title = string * string * arg_spec_full list +type cmdline_sections = options_with_title list + +(* A wrapper around Arg modules that have more logical argument order, + * and returns the remaining args. + *) +val parse_options : + cmdline_options -> Arg.usage_msg -> string array -> string list +(* Another wrapper that does Arg.align automatically *) +val usage : Arg.usage_msg -> cmdline_options -> unit + +(* Work with the options_with_title type way to organize a long + * list of command line switches. + *) +val short_usage : + Arg.usage_msg -> short_opt:cmdline_options -> unit +val long_usage : + Arg.usage_msg -> short_opt:cmdline_options -> long_opt:cmdline_sections -> + unit + +(* With the options_with_title way, we don't want the default -help and --help + * so need adapter of Arg module, not just wrapper. + *) +val arg_align2 : cmdline_options -> cmdline_options +val arg_parse2 : + cmdline_options -> Arg.usage_msg -> (unit -> unit) (* short_usage func *) -> + string list + +(* The action lib. Useful to debug supart of your system. cf some of + * my main.ml for example of use. *) +type flag_spec = Arg.key * Arg.spec * Arg.doc +type action_spec = Arg.key * Arg.doc * action_func + and action_func = (string list -> unit) + +type cmdline_actions = action_spec list +exception WrongNumberOfArguments + +val mk_action_0_arg : (unit -> unit) -> action_func +val mk_action_1_arg : (string -> unit) -> action_func +val mk_action_2_arg : (string -> string -> unit) -> action_func +val mk_action_3_arg : (string -> string -> string -> unit) -> action_func +val mk_action_4_arg : (string -> string -> string -> string -> unit) -> + action_func + +val mk_action_n_arg : (string list -> unit) -> action_func + +val options_of_actions: + string ref (* the action ref *) -> cmdline_actions -> cmdline_options +val do_action: + Arg.key -> string list (* args *) -> cmdline_actions -> unit +val action_list: + cmdline_actions -> Arg.key list + + +(* if set then will not do certain finalize so faster to go back in replay *) +val debugger : bool ref + +(* emacs spirit *) +val unwind_protect : (unit -> 'a) -> (exn -> 'b) -> 'a +(* java spirit *) +val finalize : (unit -> 'a) -> (unit -> 'b) -> 'a + +val save_excursion : 'a ref -> 'a -> (unit -> 'b) -> 'b + +val memoized : + ?use_cache:bool -> ('a, 'b) Hashtbl.t -> 'a -> (unit -> 'b) -> 'b + +exception UnixExit of int + +exception Timeout +val timeout_function : + ?verbose:bool -> + int -> (unit -> 'a) -> 'a + +type prof = ProfAll | ProfNone | ProfSome of string list +val profile : prof ref +val show_trace_profile : bool ref + +val _profile_table : (string, (float ref * int ref)) Hashtbl.t ref +val profile_code : string -> (unit -> 'a) -> 'a +val profile_diagnostic : unit -> string +val profile_code_exclusif : string -> (unit -> 'a) -> 'a +val profile_code_inside_exclusif_ok : string -> (unit -> 'a) -> 'a +val report_if_take_time : int -> string -> (unit -> 'a) -> 'a +(* similar to profile_code but print some information during execution too *) +val profile_code2 : string -> (unit -> 'a) -> 'a + +(* creation of /tmp files, a la gcc + * ex: new_temp_file "cocci" ".c" will give "/tmp/cocci-3252-434465.c" + *) +val _temp_files_created : string list ref +val save_tmp_files : bool ref +val new_temp_file : string (* prefix *) -> string (* suffix *) -> filename +val erase_temp_files : unit -> unit +val erase_this_temp_file : filename -> unit + +(* val realpath: filename -> filename *) +val fullpath: filename -> filename + +val cache_computation : + ?verbose:bool -> ?use_cache:bool -> filename -> string (* extension *) -> + (unit -> 'a) -> 'a + +val filename_without_leading_path : string -> filename -> filename +val readable: root:string -> filename -> filename + +val follow_symlinks: bool ref +val files_of_dir_or_files_no_vcs_nofilter: + string list -> filename list + +(* do some finalize, signal handling, unix exit conversion, etc *) +val main_boilerplate : (unit -> unit) -> unit + +(* type of maps from string to `a *) +module SMap : Map.S with type key = String.t +type 'a smap = 'a SMap.t + diff --git a/commons/common2.ml b/commons/common2.ml new file mode 100644 index 0000000..347ae1e --- /dev/null +++ b/commons/common2.ml @@ -0,0 +1,6186 @@ +(*s: common.ml *) +(* Yoann Padioleau + * + * Copyright (C) 1998-2009 Yoann Padioleau + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +(*x: common.ml *) +(*###########################################################################*) +(* Prelude *) +(*###########################################################################*) + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(* The following functions should be in their respective sections but + * because some functions in some sections use functions in other + * sections, and because I don't want to take care of the order of + * those sections, of those dependencies, I put the functions causing + * dependency problem here. C is better than caml on this with the + * ability to declare prototype, enabling some form of forward + * reference. + *) + +let (+>) o f = f o +let (|>) o f = f o +(*let (++) = (@) *) + +exception Timeout +exception UnixExit of int + +let rec (do_n: int -> (unit -> unit) -> unit) = fun i f -> + if i = 0 then () else (f (); do_n (i-1) f) +let rec (foldn: ('a -> int -> 'a) -> 'a -> int -> 'a) = fun f acc i -> + if i = 0 then acc else foldn f (f acc i) (i-1) + +let sum_int = List.fold_left (+) 0 + +(* could really call it 'for' :) *) +let fold_left_with_index f acc = + let rec fold_lwi_aux acc n = function + | [] -> acc + | x::xs -> fold_lwi_aux (f acc x n) (n+1) xs + in fold_lwi_aux acc 0 + + +let rec drop n xs = + match (n,xs) with + | (0,_) -> xs + | (_,[]) -> failwith "drop: not enough" + | (n,x::xs) -> drop (n-1) xs + +let rec enum_orig x n = if x = n then [n] else x::enum_orig (x+1) n + +let enum x n = + if not(x <= n) + then failwith (Printf.sprintf "bad values in enum, expect %d <= %d" x n); + let rec enum_aux acc x n = + if x = n then n::acc else enum_aux (x::acc) (x+1) n + in + List.rev (enum_aux [] x n) +let enum_safe x n = + if x > n + then [] + else enum x n + +let rec take n xs = + match (n,xs) with + | (0,_) -> [] + | (_,[]) -> failwith "Common.take: not enough" + | (n,x::xs) -> x::take (n-1) xs + + +let exclude p xs = + List.filter (fun x -> not (p x)) xs + +let last_n n l = List.rev (take n (List.rev l)) +(*let last l = List.hd (last_n 1 l) *) +let rec list_last = function + | [] -> raise Not_found + | [x] -> x + | x::y::xs -> list_last (y::xs) + + +let (list_of_string: string -> char list) = function + "" -> [] + | s -> (enum 0 ((String.length s) - 1) +> List.map (String.get s)) + +let (lines: string -> string list) = fun s -> + let rec lines_aux = function + | [] -> [] + | [x] -> if x = "" then [] else [x] + | x::xs -> + x::lines_aux xs + in + Str.split_delim (Str.regexp "\n") s +> lines_aux + + +let push v l = + l := v :: !l + +let null xs = match xs with [] -> true | _ -> false + + +let command2 s = ignore(Sys.command s) + + +let (matched: int -> string -> string) = fun i s -> + Str.matched_group i s + +let matched1 = fun s -> matched 1 s +let matched2 = fun s -> (matched 1 s, matched 2 s) +let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s) +let matched4 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s) +let matched5 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s) +let matched6 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s) +let matched7 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s, matched 7 s) + +let (with_open_stringbuf: (((string -> unit) * Buffer.t) -> unit) -> string) = + fun f -> + let buf = Buffer.create 1000 in + let pr s = Buffer.add_string buf (s ^ "\n") in + f (pr, buf); + Buffer.contents buf + + +let foldl1 p = function x::xs -> List.fold_left p x xs | _ -> failwith "foldl1" + +let rec repeat e n = + let rec repeat_aux acc = function + | 0 -> acc + | n when n < 0 -> failwith "repeat" + | n -> repeat_aux (e::acc) (n-1) in + repeat_aux [] n + +(*###########################################################################*) +(* Basic features *) +(*###########################################################################*) + +(*****************************************************************************) +(* Debugging/logging *) +(*****************************************************************************) + +(* I used this in coccinelle where the huge logging of stuff ask for + * a more organized solution that use more visual indentation hints. + * + * todo? could maybe use log4j instead ? or use Format module more + * consistently ? + *) + +let _tab_level_print = ref 0 +let _tab_indent = 5 + + +let _prefix_pr = ref "" + +let indent_do f = + _tab_level_print := !_tab_level_print + _tab_indent; + Common.finalize f + (fun () -> _tab_level_print := !_tab_level_print - _tab_indent;) + + +let pr s = + print_string !_prefix_pr; + do_n !_tab_level_print (fun () -> print_string " "); + print_string s; + print_string "\n"; + flush stdout + +let pr_no_nl s = + print_string !_prefix_pr; + do_n !_tab_level_print (fun () -> print_string " "); + print_string s; + flush stdout + + + + + + +let _chan_pr2 = ref (None: out_channel option) + +let out_chan_pr2 ?(newline=true) s = + match !_chan_pr2 with + | None -> () + | Some chan -> + output_string chan (s ^ (if newline then "\n" else "")); + flush chan + + +let pr2 s = + prerr_string !_prefix_pr; + do_n !_tab_level_print (fun () -> prerr_string " "); + prerr_string s; + prerr_string "\n"; + flush stderr; + out_chan_pr2 s; + () + +let pr2_no_nl s = + prerr_string !_prefix_pr; + do_n !_tab_level_print (fun () -> prerr_string " "); + prerr_string s; + flush stderr; + out_chan_pr2 ~newline:false s; + () + + +let pr_xxxxxxxxxxxxxxxxx () = + pr "-----------------------------------------------------------------------" + +let pr2_xxxxxxxxxxxxxxxxx () = + pr2 "-----------------------------------------------------------------------" + + +let reset_pr_indent () = + _tab_level_print := 0 + +(* old: + * let pr s = (print_string s; print_string "\n"; flush stdout) + * let pr2 s = (prerr_string s; prerr_string "\n"; flush stderr) + *) + +(* ---------------------------------------------------------------------- *) + +(* I can not use the _xxx ref tech that I use for common_extra.ml here because + * ocaml don't like the polymorphism of Dumper mixed with refs. + * + * let (_dump_func : ('a -> string) ref) = ref + * (fun x -> failwith "no dump yet, have you included common_extra.cmo?") + * let (dump : 'a -> string) = fun x -> + * !_dump_func x + * + * So I have included directly dumper.ml in common.ml. It's more practical + * when want to give script that use my common.ml, I just have to give + * this file. + *) + +(* start of dumper.ml *) + +(* Dump an OCaml value into a printable string. + * By Richard W.M. Jones (rich@annexia.org). + * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp + *) +open Printf +open Obj + +let rec dump2 r = + if is_int r then + string_of_int (magic r : int) + else ( (* Block. *) + let rec get_fields acc = function + | 0 -> acc + | n -> let n = n-1 in get_fields (field r n :: acc) n + in + let rec is_list r = + if is_int r then ( + if (magic r : int) = 0 then true (* [] *) + else false + ) else ( + let s = size r and t = tag r in + if t = 0 && s = 2 then is_list (field r 1) (* h :: t *) + else false + ) + in + let rec get_list r = + if is_int r then [] + else let h = field r 0 and t = get_list (field r 1) in h :: t + in + let opaque name = + (* XXX In future, print the address of value 'r'. Not possible in + * pure OCaml at the moment. + *) + "<" ^ name ^ ">" + in + + let s = size r and t = tag r in + + (* From the tag, determine the type of block. *) + if is_list r then ( (* List. *) + let fields = get_list r in + "[" ^ String.concat "; " (List.map dump2 fields) ^ "]" + ) + else if t = 0 then ( (* Tuple, array, record. *) + let fields = get_fields [] s in + "(" ^ String.concat ", " (List.map dump2 fields) ^ ")" + ) + + (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not + * clear if very large constructed values could have the same + * tag. XXX *) + else if t = lazy_tag then opaque "lazy" + else if t = closure_tag then opaque "closure" + else if t = object_tag then ( (* Object. *) + let fields = get_fields [] s in + let clasz, id, slots = + match fields with h::h'::t -> h, h', t | _ -> assert false in + (* No information on decoding the class (first field). So just print + * out the ID and the slots. + *) + "Object #" ^ dump2 id ^ + " (" ^ String.concat ", " (List.map dump2 slots) ^ ")" + ) + else if t = infix_tag then opaque "infix" + else if t = forward_tag then opaque "forward" + + else if t < no_scan_tag then ( (* Constructed value. *) + let fields = get_fields [] s in + "Tag" ^ string_of_int t ^ + " (" ^ String.concat ", " (List.map dump2 fields) ^ ")" + ) + else if t = string_tag then ( + "\"" ^ String.escaped (magic r : string) ^ "\"" + ) + else if t = double_tag then ( + string_of_float (magic r : float) + ) + else if t = abstract_tag then opaque "abstract" + else if t = custom_tag then opaque "custom" + else if t = final_tag then opaque "final" + else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")") + ) + +let dump v = dump2 (repr v) + +(* end of dumper.ml *) + +(* +let (dump : 'a -> string) = fun x -> + Dumper.dump x +*) + +(* ---------------------------------------------------------------------- *) +let pr2_gen x = pr2 (dump x) + +(* ---------------------------------------------------------------------- *) +let xxx_once f s = + if !Common.disable_pr2_once then pr2 s + else + if not (Hashtbl.mem Common._already_printed s) + then begin + Hashtbl.add Common._already_printed s true; + f ("(ONCE) " ^ s); + end + +let pr2_once s = xxx_once pr2 s + +(* ---------------------------------------------------------------------- *) +let mk_pr2_wrappers aref = + let fpr2 s = + if !aref + then pr2 s + else + (* just to the log file *) + out_chan_pr2 s + in + let fpr2_once s = + if !aref + then pr2_once s + else + xxx_once out_chan_pr2 s + in + fpr2, fpr2_once + +(* ---------------------------------------------------------------------- *) +(* could also be in File section *) + +let redirect_stdout file f = + begin + let chan = open_out file in + let descr = Unix.descr_of_out_channel chan in + + let saveout = Unix.dup Unix.stdout in + Unix.dup2 descr Unix.stdout; + flush stdout; + let res = f () in + flush stdout; + Unix.dup2 saveout Unix.stdout; + close_out chan; + res + end + +let redirect_stdout_opt optfile f = + match optfile with + | None -> f () + | Some outfile -> redirect_stdout outfile f + +let redirect_stdout_stderr file f = + begin + let chan = open_out file in + let descr = Unix.descr_of_out_channel chan in + + let saveout = Unix.dup Unix.stdout in + let saveerr = Unix.dup Unix.stderr in + Unix.dup2 descr Unix.stdout; + Unix.dup2 descr Unix.stderr; + flush stdout; flush stderr; + f (); + flush stdout; flush stderr; + Unix.dup2 saveout Unix.stdout; + Unix.dup2 saveerr Unix.stderr; + close_out chan; + end + +let redirect_stdin file f = + begin + let chan = open_in file in + let descr = Unix.descr_of_in_channel chan in + + let savein = Unix.dup Unix.stdin in + Unix.dup2 descr Unix.stdin; + f (); + Unix.dup2 savein Unix.stdin; + close_in chan; + end + +let redirect_stdin_opt optfile f = + match optfile with + | None -> f () + | Some infile -> redirect_stdin infile f + + +(* cf end +let with_pr2_to_string f = +*) + + +(* ---------------------------------------------------------------------- *) + +(* old: include Printf, include are evil and graph_code_cmt does not like them*) +(* cf common.mli, fprintf, printf, eprintf, sprintf. + * also what is this ? + * val bprintf : Buffer.t -> ('a, Buffer.t, unit) format -> 'a + * val kprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b + *) + +(* ex of printf: + * printf "%02d" i + * for padding + *) + +let spf = Printf.sprintf + +(* ---------------------------------------------------------------------- *) + +let _chan = ref stderr +let start_log_file () = + let filename = (spf "/tmp/debugml%d:%d" (Unix.getuid()) (Unix.getpid())) in + pr2 (spf "now using %s for logging" filename); + _chan := open_out filename + + +let dolog s = output_string !_chan (s ^ "\n"); flush !_chan + +let verbose_level = ref 1 +let log s = if !verbose_level >= 1 then dolog s +let log2 s = if !verbose_level >= 2 then dolog s +let log3 s = if !verbose_level >= 3 then dolog s +let log4 s = if !verbose_level >= 4 then dolog s + +let if_log f = if !verbose_level >= 1 then f () +let if_log2 f = if !verbose_level >= 2 then f () +let if_log3 f = if !verbose_level >= 3 then f () +let if_log4 f = if !verbose_level >= 4 then f () + +(* ---------------------------------------------------------------------- *) + +let pause () = (pr2 "pause: type return"; ignore(read_line ())) + +(* src: from getopt from frish *) +let bip () = Printf.printf "\007"; flush stdout +let wait () = Unix.sleep 1 + +(* was used by fix_caml *) +let _trace_var = ref 0 +let add_var() = incr _trace_var +let dec_var() = decr _trace_var +let get_var() = !_trace_var + +let (print_n: int -> string -> unit) = fun i s -> + do_n i (fun () -> print_string s) +let (printerr_n: int -> string -> unit) = fun i s -> + do_n i (fun () -> prerr_string s) + +let _debug = ref true +let debugon () = _debug := true +let debugoff () = _debug := false +let debug f = if !_debug then f () else () + +(*****************************************************************************) +(* Profiling *) +(*****************************************************************************) + +(* now near cmd_to_list: let get_mem() = *) + + +let memory_stat () = + let stat = Gc.stat() in + let conv_mo x = x * 4 / 1000000 in + Printf.sprintf "maximal = %d Mo\n" (conv_mo stat.Gc.top_heap_words) ^ + Printf.sprintf "current = %d Mo\n" (conv_mo stat.Gc.heap_words) ^ + Printf.sprintf "lives = %d Mo\n" (conv_mo stat.Gc.live_words) + (* Printf.printf "fragments = %d Mo\n" (conv_mo stat.Gc.fragments); *) + +let timenow () = + "sys:" ^ (string_of_float (Sys.time ())) ^ " seconds" ^ + ":real:" ^ + (let tm = Unix.time () +> Unix.gmtime in + tm.Unix.tm_min +> string_of_int ^ " min:" ^ + tm.Unix.tm_sec +> string_of_int ^ ".00 seconds") + +let _count1 = ref 0 +let _count2 = ref 0 +let _count3 = ref 0 +let _count4 = ref 0 +let _count5 = ref 0 + +let count1 () = incr _count1 +let count2 () = incr _count2 +let count3 () = incr _count3 +let count4 () = incr _count4 +let count5 () = incr _count5 + +let profile_diagnostic_basic () = + Printf.sprintf + "count1 = %d\ncount2 = %d\ncount3 = %d\ncount4 = %d\ncount5 = %d\n" + !_count1 !_count2 !_count3 !_count4 !_count5 + +let time_func f = + (* let _ = Timing () in *) + let x = f () in + (* let _ = Timing () in *) + x + +(*****************************************************************************) +(* Test *) +(*****************************************************************************) + +(* See also OUnit *) + +(* commented because does not play well with js_of_ocaml +*) +let example b = + if b + then () + else failwith ("ASSERT FAILURE: " ^ (Printexc.get_backtrace ())) +let _ex1 = assert (enum 1 4 = [1;2;3;4]) + +let assert_equal a b = + if not (a = b) + then failwith ("assert_equal: those 2 values are not equal:\n\t" ^ + (dump a) ^ "\n\t" ^ (dump b) ^ "\n") + +let (example2: string -> bool -> unit) = fun s b -> + try assert b with x -> failwith s + +(*-------------------------------------------------------------------*) +let _list_bool = ref [] + +let (example3: string -> bool -> unit) = fun s b -> + _list_bool := (s,b)::(!_list_bool) + +(* could introduce a fun () otherwise the calculus is made at compile time + * and this can be long. This would require to redefine test_all. + * let (example3: string -> (unit -> bool) -> unit) = fun s func -> + * _list_bool := (s,func):: (!_list_bool) + * + * I would like to do as a func that take 2 terms, and make an = over it + * avoid to add this ugly fun (), but pb of type, cant do that :( + *) + + +let (test_all: unit -> unit) = fun () -> + List.iter (fun (s, b) -> + Printf.printf "%s: %s\n" s (if b then "passed" else "failed") + ) !_list_bool + +let (test: string -> unit) = fun s -> + Printf.printf "%s: %s\n" s + (if (List.assoc s (!_list_bool)) then "passed" else "failed") + + +let (++) a b = + Common.profile_code "++" (fun () -> a @ b) + +let _ex = example3 "++" ([1;2]@[3;4;5] = [1;2;3;4;5]) + +(*-------------------------------------------------------------------*) +(* Regression testing *) +(*-------------------------------------------------------------------*) + +(* cf end of file. It uses too many other common functions so I + * have put the code at the end of this file. + *) + + + +(* todo? take code from julien signoles in calendar-2.0.2/tests *) +(* + +(* Generic functions used in the tests. *) + +val reset : unit -> unit +val nb_ok : unit -> int +val nb_bug : unit -> int +val test : bool -> string -> unit +val test_exn : 'a Lazy.t -> string -> unit + + +let ok_ref = ref 0 +let ok () = incr ok_ref +let nb_ok () = !ok_ref + +let bug_ref = ref 0 +let bug () = incr bug_ref +let nb_bug () = !bug_ref + +let reset () = + ok_ref := 0; + bug_ref := 0 + +let test x s = + if x then ok () else begin Printf.printf "%s\n" s; bug () end;; + +let test_exn x s = + try + ignore (Lazy.force x); + Printf.printf "%s\n" s; + bug () + with _ -> + ok ();; +*) + + +(*****************************************************************************) +(* Quickcheck like (sfl) *) +(*****************************************************************************) + +(* related work: + * - http://cedeela.fr/quickcheck-for-ocaml.html + *) + +(*---------------------------------------------------------------------------*) +(* generators *) +(*---------------------------------------------------------------------------*) +type 'a gen = unit -> 'a + +let (ig: int gen) = fun () -> + Random.int 10 +let (lg: ('a gen) -> ('a list) gen) = fun gen () -> + foldn (fun acc i -> (gen ())::acc) [] (Random.int 10) +let (pg: ('a gen) -> ('b gen) -> ('a * 'b) gen) = fun gen1 gen2 () -> + (gen1 (), gen2 ()) +let polyg = ig +let (ng: (string gen)) = fun () -> + "a" ^ (string_of_int (ig ())) + +let (oneofl: ('a list) -> 'a gen) = fun xs () -> + List.nth xs (Random.int (List.length xs)) +(* let oneofl l = oneof (List.map always l) *) + +let (oneof: (('a gen) list) -> 'a gen) = fun xs -> + List.nth xs (Random.int (List.length xs)) + +let (always: 'a -> 'a gen) = fun e () -> e + +let (frequency: ((int * ('a gen)) list) -> 'a gen) = fun xs -> + let sums = sum_int (List.map fst xs) in + let i = Random.int sums in + let rec freq_aux acc = function + | (x,g)::xs -> if i < acc+x then g else freq_aux (acc+x) xs + | _ -> failwith "frequency" + in + freq_aux 0 xs +let frequencyl l = frequency (List.map (fun (i,e) -> (i,always e)) l) + +(* +let b = oneof [always true; always false] () +let b = frequency [3, always true; 2, always false] () +*) + +(* cant do this: + * let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneofl [[]; lg gen ()] + * nor + * let rec (lg: ('a gen) -> ('a list) gen) = fun gen -> oneof [always []; lg gen] + * + * because caml is not as lazy as haskell :( fix the pb by introducing a size + * limit. take the bounds/size as parameter. morover this is needed for + * more complex type. + * + * how make a bintreeg ?? we need recursion + * + * let rec (bintreeg: ('a gen) -> ('a bintree) gen) = fun gen () -> + * let rec aux n = + * if n = 0 then (Leaf (gen ())) + * else frequencyl [1, Leaf (gen ()); 4, Branch ((aux (n / 2)), aux (n / 2))] + * () + * in aux 20 + * + *) + + +(*---------------------------------------------------------------------------*) +(* property *) +(*---------------------------------------------------------------------------*) + +(* todo: a test_all_laws, better syntax (done already a little with ig in + * place of intg. En cas d'erreur, print the arg that not respect + * + * todo: with monitoring, as in haskell, laws = laws2, no need for 2 func, + * but hard i found + * + * todo classify, collect, forall + *) + + +(* return None when good, and Just the_problematic_case when bad *) +let (laws: string -> ('a -> bool) -> ('a gen) -> 'a option) = fun s func gen -> + let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in + let res = List.filter (fun (x,b) -> not b) res in + if res = [] then None else Some (fst (List.hd res)) + +let rec (statistic_number: ('a list) -> (int * 'a) list) = function + | [] -> [] + | x::xs -> let (splitg, splitd) = List.partition (fun y -> y = x) xs in + (1+(List.length splitg), x)::(statistic_number splitd) + +(* in pourcentage *) +let (statistic: ('a list) -> (int * 'a) list) = fun xs -> + let stat_num = statistic_number xs in + let totals = sum_int (List.map fst stat_num) in + List.map (fun (i, v) -> ((i * 100) / totals), v) stat_num + +let (laws2: + string -> ('a -> (bool * 'b)) -> ('a gen) -> + ('a option * ((int * 'b) list ))) = + fun s func gen -> + let res = foldn (fun acc i -> let n = gen() in (n, func n)::acc) [] 1000 in + let stat = statistic (List.map (fun (x,(b,v)) -> v) res) in + let res = List.filter (fun (x,(b,v)) -> not b) res in + if res = [] then (None, stat) else (Some (fst (List.hd res)), stat) + + + +(* todo, do with coarbitrary ?? idea is that given a 'a, generate a 'b + * depending of 'a and gen 'b, that is modify gen 'b, what is important is + * that each time given the same 'a, we must get the same 'b !!! + *) + +(* +let (fg: ('a gen) -> ('b gen) -> ('a -> 'b) gen) = fun gen1 gen2 () -> +let b = laws "funs" (fun (f,g,h) -> x <= y ==> (max x y = y) )(pg ig ig) + *) + +(* +let one_of xs = List.nth xs (Random.int (List.length xs)) +let take_one xs = + if empty xs then failwith "Take_one: empty list" + else + let i = Random.int (List.length xs) in + List.nth xs i, filter_index (fun j _ -> i <> j) xs +*) + +(*****************************************************************************) +(* Persistence *) +(*****************************************************************************) + +let get_value filename = + let chan = open_in filename in + let x = input_value chan in (* <=> Marshal.from_channel *) + (close_in chan; x) + +let write_value valu filename = + let chan = open_out filename in + (output_value chan valu; (* <=> Marshal.to_channel *) + (* Marshal.to_channel chan valu [Marshal.Closures]; *) + close_out chan) + +let write_back func filename = + write_value (func (get_value filename)) filename + + +let read_value f = get_value f + + +let marshal__to_string2 v flags = + Marshal.to_string v flags +let marshal__to_string a b = + Common.profile_code "Marshalling" (fun () -> marshal__to_string2 a b) + +let marshal__from_string2 v flags = + Marshal.from_string v flags +let marshal__from_string a b = + Common.profile_code "Marshalling" (fun () -> marshal__from_string2 a b) + + + +(*****************************************************************************) +(* Counter *) +(*****************************************************************************) +let _counter = ref 0 +let counter () = (_counter := !_counter +1; !_counter) + +let _counter2 = ref 0 +let counter2 () = (_counter2 := !_counter2 +1; !_counter2) + +let _counter3 = ref 0 +let counter3 () = (_counter3 := !_counter3 +1; !_counter3) + +type timestamp = int + +(*****************************************************************************) +(* String_of *) +(*****************************************************************************) +(* To work with the macro system autogenerated string_of and print_ function + (kind of deriving a la haskell) *) + +(* int, bool, char, float, ref ?, string *) + +let string_of_string s = "\"" ^ s "\"" + +let string_of_list f xs = + "[" ^ (xs +> List.map f +> String.concat ";" ) ^ "]" + +let string_of_unit () = "()" + +let string_of_array f xs = + "[|" ^ (xs +> Array.to_list +> List.map f +> String.concat ";") ^ "|]" + +let string_of_option f = function + | None -> "None " + | Some x -> "Some " ^ (f x) + + + + +let print_bool x = print_string (if x then "True" else "False") + +let print_option pr = function + | None -> print_string "None" + | Some x -> print_string "Some ("; pr x; print_string ")" + +let print_list pr xs = + begin + print_string "["; + List.iter (fun x -> pr x; print_string ",") xs; + print_string "]"; + end + +(* specialised +let (string_of_list: char list -> string) = + List.fold_left (fun acc x -> acc^(Char.escaped x)) "" +*) + + +let rec print_between between fn = function + | [] -> () + | [x] -> fn x + | x::xs -> fn x; between(); print_between between fn xs + + + + +let adjust_pp_with_indent f = + Format.open_box !_tab_level_print; + (*Format.force_newline();*) + f (); + Format.close_box (); + Format.print_newline() + +let adjust_pp_with_indent_and_header s f = + Format.open_box (!_tab_level_print + String.length s); + do_n !_tab_level_print (fun () -> Format.print_string " "); + Format.print_string s; + f (); + Format.close_box (); + Format.print_newline() + + + +let pp_do_in_box f = Format.open_box 1; f (); Format.close_box () +let pp_do_in_zero_box f = Format.open_box 0; f (); Format.close_box () + +let pp_f_in_box f = + Format.open_box 1; + let res = f () in + Format.close_box (); + res + +let pp s = Format.print_string s + +(* + * use as + * let category__str_conv = [ + * BackGround, "background"; + * ForeGround, "ForeGround"; + * ... + * ] + * + * let (category_of_string, str_of_category) = + * Common.mk_str_func_of_assoc_conv category__str_conv + * + *) +let mk_str_func_of_assoc_conv xs = + let swap (x,y) = (y,x) in + + (fun s -> + let xs' = List.map swap xs in + List.assoc s xs' + ), + (fun a -> + List.assoc a xs + ) + + + +(* julia: convert something printed using format to print into a string *) +(* now at bottom of file +let format_to_string f = + ... +*) + + + +(*****************************************************************************) +(* Macro *) +(*****************************************************************************) + +(* put your macro in macro.ml4, and you can test it interactivly as in lisp *) +let macro_expand s = + let c = open_out "/tmp/ttttt.ml" in + begin + output_string c s; close_out c; + command2 ("ocamlc -c -pp 'camlp4o pa_extend.cmo q_MLast.cmo -impl' " ^ + "-I +camlp4 -impl macro.ml4"); + command2 "camlp4o ./macro.cmo pr_o.cmo /tmp/ttttt.ml"; + command2 "rm -f /tmp/ttttt.ml"; + end + +(* +let t = macro_expand "{ x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x>2 and y<3}" +let x = { x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x > 2 and y < 3} +let t = macro_expand "{1 .. 10}" +let x = {1 .. 10} +> List.map (fun i -> i) +let t = macro_expand "[1;2] to append to [2;4]" +let t = macro_expand "{x = 2; x = 3}" + +let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)" +*) + + + +(*****************************************************************************) +(* Composition/Control *) +(*****************************************************************************) + +(* now in prelude: + * let (+>) o f = f o + *) +let (+!>) refo f = refo := f !refo +(* alternatives: + * let ((@): 'a -> ('a -> 'b) -> 'b) = fun a b -> b a + * let o f g x = f (g x) + *) + +let ($) f g x = g (f x) +let compose f g x = f (g x) +(* dont work :( let ( rond_utf_symbol ) f g x = f(g(x)) *) + +(* trick to have something similar to the 1 `max` 4 haskell infix notation. + by Keisuke Nakano on the caml mailing list. +> let ( /* ) x y = y x +> and ( */ ) x y = x y +or + let ( <| ) x y = y x + and ( |> ) x y = x y + +> Then we can make an infix operator <| f |> for a binary function f. +*) + +let flip f = fun a b -> f b a + +let curry f x y = f (x,y) +let uncurry f (a,b) = f a b + +let id = fun x -> x + +let const x = (fun y -> x) + +let do_nothing () = () + +let rec applyn n f o = if n = 0 then o else applyn (n-1) f (f o) + +let forever f = + while true do + f (); + done + + +class ['a] shared_variable_hook (x:'a) = + object(self) + val mutable data = x + val mutable registered = [] + method set x = + begin + data <- x; + pr "refresh registered"; + registered +> List.iter (fun f -> f ()); + end + method get = data + method modify f = self#set (f self#get) + method register f = + registered <- f :: registered + end + +(* src: from aop project. was called ptFix *) +let rec fixpoint trans elem = + let image = trans elem in + if (image = elem) + then elem (* point fixe *) + else fixpoint trans image + +(* le point fixe pour les objets. was called ptFixForObjetct *) +let rec fixpoint_for_object trans elem = + let image = trans elem in + if (image#equal elem) then elem (* point fixe *) + else fixpoint_for_object trans image + +let (add_hook: ('a -> ('a -> 'b) -> 'b) ref -> ('a -> ('a -> 'b) -> 'b) -> unit) = + fun var f -> + let oldvar = !var in + var := fun arg k -> f arg (fun x -> oldvar x k) + +let (add_hook_action: ('a -> unit) -> ('a -> unit) list ref -> unit) = + fun f hooks -> + push f hooks + +let (run_hooks_action: 'a -> ('a -> unit) list ref -> unit) = + fun obj hooks -> + !hooks +> List.iter (fun f -> try f obj with _ -> ()) + + +type 'a mylazy = (unit -> 'a) + +(* a la emacs. + * bugfix: add finalize, otherwise exns can mess up the reference + *) +let save_excursion reference newv f = + let old = !reference in + reference := newv; + Common.finalize f (fun _ -> reference := old;) + +let save_excursion_and_disable reference f = + save_excursion reference false (fun () -> + f () + ) + +let save_excursion_and_enable reference f = + save_excursion reference true (fun () -> + f () + ) + + +let memoized ?(use_cache=true) h k f = + if not use_cache + then f () + else + try Hashtbl.find h k + with Not_found -> + let v = f () in + begin + Hashtbl.add h k v; + v + end + +let cache_in_ref myref f = + match !myref with + | Some e -> e + | None -> + let e = f () in + myref := Some e; + e + +let oncef f = + let already = ref false in + (fun x -> + if not !already + then begin already := true; f x end + ) + +let once aref f = + if !aref then () + else begin + aref := true; + f () + end + +(* cache_file, cf below *) + +let before_leaving f x = + f x; + x + +(* finalize, cf prelude *) + + +(* cheat *) +let rec y f = fun x -> f (y f) x + +(*****************************************************************************) +(* Concurrency *) +(*****************************************************************************) + +(* from http://en.wikipedia.org/wiki/File_locking + * + * "When using file locks, care must be taken to ensure that operations + * are atomic. When creating the lock, the process must verify that it + * does not exist and then create it, but without allowing another + * process the opportunity to create it in the meantime. Various + * schemes are used to implement this, such as taking advantage of + * system calls designed for this purpose (but such system calls are + * not usually available to shell scripts) or by creating the lock file + * under a temporary name and then attempting to move it into place." + * + * => can't use 'if(not (file_exist xxx)) then create_file xxx' because + * file_exist/create_file are not in atomic section (classic problem). + * + * from man open: + * + * "O_EXCL When used with O_CREAT, if the file already exists it + * is an error and the open() will fail. In this context, a + * symbolic link exists, regardless of where it points to. + * O_EXCL is broken on NFS file systems; programs which + * rely on it for performing locking tasks will contain a + * race condition. The solution for performing atomic file + * locking using a lockfile is to create a unique file on + * the same file system (e.g., incorporating host- name and + * pid), use link(2) to make a link to the lockfile. If + * link(2) returns 0, the lock is successful. Otherwise, + * use stat(2) on the unique file to check if its link + * count has increased to 2, in which case the lock is also + * successful." + + *) + +exception FileAlreadyLocked + +(* Racy if lock file on NFS!!! But still racy with recent Linux ? *) +let acquire_file_lock filename = + pr2 ("Locking file: " ^ filename); + try + let _fd = Unix.openfile filename [Unix.O_CREAT;Unix.O_EXCL] 0o777 in + () + with Unix.Unix_error (e, fm, argm) -> + pr2 (spf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm); + raise FileAlreadyLocked + + +let release_file_lock filename = + pr2 ("Releasing file: " ^ filename); + Unix.unlink filename; + () + + + +(*****************************************************************************) +(* Error managment *) +(*****************************************************************************) + +exception Here +exception ReturnExn + +exception WrongFormat of string + +(* old: let _TODO () = failwith "TODO", now via fix_caml with raise Todo *) + +let internal_error s = failwith ("internal error: "^s) +let error_cant_have x = internal_error ("cant have this case" ^(dump x)) +let myassert cond = if cond then () else failwith "assert error" + + + +(* before warning I was forced to do stuff like this: + * + * let (fixed_int_to_posmap: fixed_int -> posmap) = fun fixed -> + * let v = ((fix_to_i fixed) / (power 2 16)) in + * let _ = Printf.printf "coord xy = %d\n" v in + * v + * + * The need for printf make me force to name stuff :( + * How avoid ? use 'it' special keyword ? + * In fact dont have to name it, use +> (fun v -> ...) so when want + * erase debug just have to erase one line. + *) +let warning s v = (pr2 ("Warning: " ^ s ^ "; value = " ^ (dump v)); v) + + + + +let exn_to_s exn = + Printexc.to_string exn + +let exn_to_s_with_backtrace exn = + Printexc.to_string exn ^ "\n" ^ Printexc.get_backtrace () + +(* alias *) +let string_of_exn exn = exn_to_s exn + + +(* want or of merd, but cant cos cant put die ... in b (strict call) *) +let (|||) a b = try a with _ -> b + +(* emacs/lisp inspiration, (vouillon does that too in unison I think) *) + +(* now in Prelude: + * let unwind_protect f cleanup = ... + * let finalize f cleanup = ... + *) + +type error = Error of string + +(* sometimes to get help from ocaml compiler to tell me places where + * I should update, we sometimes need to change some type from pair + * to triple, hence this kind of fake type. + *) +type evotype = unit +let evoval = () + +(*****************************************************************************) +(* Environment *) +(*****************************************************************************) + +let _check_stack = ref true +let check_stack_size limit = + if !_check_stack then begin + pr2 "checking stack size (do ulimit -s 40000 if problem)"; + let rec aux i = + if i = limit + then 0 + else 1 + aux (i + 1) + in + assert(aux 0 = limit); + () + end + +let test_check_stack_size limit = + (* bytecode: 100000000 *) + (* native: 10000000 *) + check_stack_size (int_of_string limit) + + +(* only relevant in bytecode, in native the stacklimit is the os stacklimit + * (adjustable by ulimit -s) + *) +let _init_gc_stack = + () +(* commented because cause pbs with js_of_ocaml + Gc.set {(Gc.get ()) with Gc.stack_limit = 100 * 1024 * 1024} +*) + +(* if process a big set of files then dont want get overflow in the middle + * so for this we are ready to spend some extra time at the beginning that + * could save far more later. + * + * On Centos 5.2 with ulimit -s 40000 I can only go up to 2000000 in + * native mode (and it crash with ulimit -s 10000, which is what we want). + *) +let check_stack_nbfiles nbfiles = + if nbfiles > 200 + then check_stack_size 2000000 + +(*****************************************************************************) +(* Equality *) +(*****************************************************************************) + + +(* src: caml mailing list ? *) +let (=|=) : int -> int -> bool = (=) +let (=<=) : char -> char -> bool = (=) +let (=$=) : string -> string -> bool = (=) +let (=:=) : bool -> bool -> bool = (=) + +let (=*=) = (=) + +(* if really want to forbid to use '=' +let (=) = (=|=) +*) +let (=) () () = false + +(*x: common.ml *) +(*###########################################################################*) +(* Basic types *) +(*###########################################################################*) + + +(*****************************************************************************) +(* Bool *) +(*****************************************************************************) +let (==>) b1 b2 = if b1 then b2 else true (* could use too => *) + +(* superseded by another <=> below +let (<=>) a b = if a =*= b then 0 else if a < b then -1 else 1 +*) + +let xor a b = not (a =*= b) + + +(*****************************************************************************) +(* Char *) +(*****************************************************************************) + +let string_of_char c = String.make 1 c + +let is_single = String.contains ",;()[]{}_`" +let is_symbol = String.contains "!@#$%&*+./<=>?\\^|:-~" +let is_space = String.contains "\n\t " +let cbetween min max c = + (int_of_char c) <= (int_of_char max) && + (int_of_char c) >= (int_of_char min) +let is_upper = cbetween 'A' 'Z' +let is_lower = cbetween 'a' 'z' +let is_alpha c = is_upper c || is_lower c +let is_digit = cbetween '0' '9' + +let string_of_chars cs = cs +> List.map (String.make 1) +> String.concat "" + + + +(*****************************************************************************) +(* Num *) +(*****************************************************************************) + +(* since 3.08, div by 0 raise Div_by_rezo, and not anymore a hardware trap :)*) +let (/!) x y = if y =|= 0 then (log "common.ml: div by 0"; 0) else x / y + +(* now in prelude + * let rec (do_n: int -> (unit -> unit) -> unit) = fun i f -> + * if i = 0 then () else (f (); do_n (i-1) f) + *) + +let times f n = do_n n f + +(* now in prelude + * let rec (foldn: ('a -> int -> 'a) -> 'a -> int -> 'a) = fun f acc i -> + * if i = 0 then acc else foldn f (f acc i) (i-1) + *) + +let sum_float = List.fold_left (+.) 0.0 +(* in prelude: let sum_int = List.fold_left (+) 0 *) + +let pi = 3.14159265358979323846 +let pi2 = pi /. 2.0 +let pi4 = pi /. 4.0 + +(* 180 = pi *) +let (deg_to_rad: float -> float) = fun deg -> + (deg *. pi) /. 180.0 + +let clampf = function + | n when n < 0.0 -> 0.0 + | n when n > 1.0 -> 1.0 + | n -> n + +let square x = x *. x + +let rec power x n = if n =|= 0 then 1 else x * power x (n-1) + +let between i min max = i > min && i < max + +let (between_strict: int -> int -> int -> bool) = fun a b c -> + a < b && b < c + + +let borne ~min ~max x = + if x > max then max + else if x < min then min + else x + + +let bitrange x p = let v = power 2 p in between x (-v) v + +(* descendant *) +let (prime1: int -> int option) = fun x -> + let rec prime1_aux n = + if n =|= 1 then None + else + if (x / n) * n =|= x then Some n else prime1_aux (n-1) + in if x =|= 1 then None else if x < 0 then failwith "negative" else prime1_aux (x-1) + +(* montant, better *) +let (prime: int -> int option) = fun x -> + let rec prime_aux n = + if n =|= x then None + else + if (x / n) * n =|= x then Some n else prime_aux (n+1) + in if x =|= 1 then None else if x < 0 then failwith "negative" else prime_aux 2 + +let sum xs = List.fold_left (+) 0 xs +let product = List.fold_left ( * ) 1 + + +let decompose x = + let rec decompose x = + if x =|= 1 then [] + else + (match prime x with + | None -> [x] + | Some n -> n::decompose (x / n) + ) + in assert (product (decompose x) =|= x); decompose x + +let mysquare x = x * x +let sqr a = a *. a + + +type compare = Equal | Inf | Sup +let (<=>) a b = if a =*= b then Equal else if a < b then Inf else Sup +let (<==>) a b = if a =*= b then 0 else if a < b then -1 else 1 + +type uint = int + + +let int_of_stringchar s = + fold_left_with_index (fun acc e i -> acc + (Char.code e*(power 8 i))) 0 (List.rev (list_of_string s)) + +let int_of_base s base = + fold_left_with_index (fun acc e i -> + let j = Char.code e - Char.code '0' in + if j >= base then failwith "not in good base" + else acc + (j*(power base i)) + ) + 0 (List.rev (list_of_string s)) + +let int_of_stringbits s = int_of_base s 2 +let _ = assert (int_of_stringbits "1011" =|= 1*8 + 1*2 + 1*1) + +let int_of_octal s = int_of_base s 8 +let _ = assert (int_of_octal "017" =|= 15) + +(* let int_of_hex s = int_of_base s 16, NONONONO cos 'A' - '0' does not give 10 !! *) + +let int_of_all s = + if String.length s >= 2 && (String.get s 0 =<= '0') && is_digit (String.get s 1) + then int_of_octal s else int_of_string s + + +let (+=) ref v = ref := !ref + v +let (-=) ref v = ref := !ref - v + +let pourcent x total = + (x * 100) / total +let pourcent_float x total = + ((float_of_int x) *. 100.0) /. (float_of_int total) + +let pourcent_float_of_floats x total = + (x *. 100.0) /. total + + +let pourcent_good_bad good bad = + (good * 100) / (good + bad) + +let pourcent_good_bad_float good bad = + (float_of_int good *. 100.0) /. (float_of_int good +. float_of_int bad) + +type 'a max_with_elem = int ref * 'a ref +let update_max_with_elem (aref, aelem) ~is_better (newv, newelem) = + if is_better newv aref + then begin + aref := newv; + aelem := newelem; + end + +(*****************************************************************************) +(* Numeric/overloading *) +(*****************************************************************************) + +type 'a numdict = + NumDict of (('a-> 'a -> 'a) * + ('a-> 'a -> 'a) * + ('a-> 'a -> 'a) * + ('a -> 'a));; + +let add (NumDict(a, m, d, n)) = a;; +let mul (NumDict(a, m, d, n)) = m;; +let div (NumDict(a, m, d, n)) = d;; +let neg (NumDict(a, m, d, n)) = n;; + +let numd_int = NumDict(( + ),( * ),( / ),( ~- ));; +let numd_float = NumDict(( +. ),( *. ), ( /. ),( ~-. ));; +let testd dict n = + let ( * ) x y = mul dict x y in + let ( / ) x y = div dict x y in + let ( + ) x y = add dict x y in + (* Now you can define all sorts of things in terms of *, /, + *) + let f num = (num * num) / (num + num) in + f n;; + + + +module ArithFloatInfix = struct + let (+..) = (+) + let (-..) = (-) + let (/..) = (/) + let ( *.. ) = ( * ) + + + let (+) = (+.) + let (-) = (-.) + let (/) = (/.) + let ( * ) = ( *. ) + + let (+=) ref v = ref := !ref + v + let (-=) ref v = ref := !ref - v + +end + + + +(*****************************************************************************) +(* Tuples *) +(*****************************************************************************) + +type 'a pair = 'a * 'a +type 'a triple = 'a * 'a * 'a + +let fst3 (x,_,_) = x +let snd3 (_,y,_) = y +let thd3 (_,_,z) = z + +let sndthd (a,b,c) = (b,c) + +let map_fst f (x, y) = f x, y +let map_snd f (x, y) = x, f y + +let pair f (x,y) = (f x, f y) +let triple f (x,y,z) = (f x, f y, f z) + +(* for my ocamlbeautify script *) +(* +let snd = snd +let fst = fst +*) + +let double a = a,a +let swap (x,y) = (y,x) + + +let tuple_of_list1 = function [a] -> a | _ -> failwith "tuple_of_list1" +let tuple_of_list2 = function [a;b] -> a,b | _ -> failwith "tuple_of_list2" +let tuple_of_list3 = function [a;b;c] -> a,b,c | _ -> failwith "tuple_of_list3" +let tuple_of_list4 = function [a;b;c;d] -> a,b,c,d | _ -> failwith "tuple_of_list4" +let tuple_of_list5 = function [a;b;c;d;e] -> a,b,c,d,e | _ -> failwith "tuple_of_list5" +let tuple_of_list6 = function [a;b;c;d;e;f] -> a,b,c,d,e,f | _ -> failwith "tuple_of_list6" + + +(*****************************************************************************) +(* Maybe *) +(*****************************************************************************) + +(* type 'a maybe = Just of 'a | None *) + +type ('a,'b) either = Left of 'a | Right of 'b + (* with sexp *) +type ('a, 'b, 'c) either3 = Left3 of 'a | Middle3 of 'b | Right3 of 'c + (* with sexp *) + +let just = function + | (Some x) -> x + | _ -> failwith "just: pb" + +let some = just + + +let fmap f = function + | None -> None + | Some x -> Some (f x) +let map_option = fmap + +let do_option f = function + | None -> () + | Some x -> f x +let opt = do_option + +let optionise f = + try Some (f ()) with Not_found -> None + + + +(* pixel *) +let some_or = function + | None -> id + | Some e -> fun _ -> e + +let option_to_list = function + | None -> [] + | Some x -> [x] + + +let partition_either f l = + let rec part_either left right = function + | [] -> (List.rev left, List.rev right) + | x :: l -> + (match f x with + | Left e -> part_either (e :: left) right l + | Right e -> part_either left (e :: right) l) in + part_either [] [] l + +let partition_either3 f l = + let rec part_either left middle right = function + | [] -> (List.rev left, List.rev middle, List.rev right) + | x :: l -> + (match f x with + | Left3 e -> part_either (e :: left) middle right l + | Middle3 e -> part_either left (e :: middle) right l + | Right3 e -> part_either left middle (e :: right) l) in + part_either [] [] [] l + + +(* pixel *) +let rec filter_some = function + | [] -> [] + | None :: l -> filter_some l + | Some e :: l -> e :: filter_some l + +let map_filter f xs = xs +> List.map f +> filter_some + +let rec find_some p = function + | [] -> raise Not_found + | x :: l -> + match p x with + | Some v -> v + | None -> find_some p l + +let rec find_some_opt p = function + | [] -> None + | x :: l -> + match p x with + | Some v -> Some v + | None -> find_some_opt p l + +(* same +let map_find f xs = + xs +> List.map f +> List.find (function Some x -> true | None -> false) + +> (function Some x -> x | None -> raise Impossible) +*) + + +let list_to_single_or_exn xs = + match xs with + | [] -> raise Not_found + | x::y::zs -> raise Common.Multi_found + | [x] -> x + + +let rec (while_some: gen:(unit-> 'a option) -> f:('a -> 'b) -> unit -> 'b list) + = fun ~gen ~f () -> + match gen () with + | None -> [] + | Some x -> + let e = f x in + let rest = while_some gen f () in + e::rest + +(* perl idiom *) +let (||=) aref vf = + match !aref with + | None -> aref := Some (vf ()) + | Some _ -> () + +let (>>=) m1 m2 = + match m1 with + | None -> None + | Some x -> m2 x + +(* http://roscidus.com/blog/blog/2013/10/13/ocaml-tips/#handling-option-types*) +let (|?) maybe default = + match maybe with + | Some v -> v + | None -> Lazy.force default + +(*****************************************************************************) +(* TriBool *) +(*****************************************************************************) + +type bool3 = True3 | False3 | TrueFalsePb3 of string + + + +(*****************************************************************************) +(* Regexp, can also use PCRE *) +(*****************************************************************************) + + +(* put before String section because String section use some =~ *) + +(* let gsubst = global_replace *) + + +let (==~) s re = + Common.profile_code "Common.==~" (fun () -> + Str.string_match re s 0 + ) + +let _memo_compiled_regexp = Hashtbl.create 101 +let candidate_match_func s re = + (* old: Str.string_match (Str.regexp re) s 0 *) + let compile_re = + memoized _memo_compiled_regexp re (fun () -> Str.regexp re) + in + Str.string_match compile_re s 0 + +let match_func s re = + Common.profile_code "Common.=~" (fun () -> candidate_match_func s re) + +let (=~) s re = + match_func s re + + + + + +let string_match_substring re s = + try let _i = Str.search_forward re s 0 in true + with Not_found -> false + +(* +let _ = + example(string_match_substring (Str.regexp "foo") "a foo b") +let _ = + example(string_match_substring (Str.regexp "\\bfoo\\b") "a foo b") +let _ = + example(string_match_substring (Str.regexp "\\bfoo\\b") "a\n\nfoo b") +let _ = + example(string_match_substring (Str.regexp "\\bfoo_bar\\b") "a\n\nfoo_bar b") +*) +(* does not work :( +let _ = + example(string_match_substring (Str.regexp "\\bfoo_bar2\\b") "a\n\nfoo_bar2 b") +*) + + + +let (regexp_match: string -> string -> string) = fun s re -> + assert(s =~ re); + Str.matched_group 1 s + +(* beurk, side effect code, but hey, it is convenient *) +(* now in prelude + * let (matched: int -> string -> string) = fun i s -> + * Str.matched_group i s + * + * let matched1 = fun s -> matched 1 s + * let matched2 = fun s -> (matched 1 s, matched 2 s) + * let matched3 = fun s -> (matched 1 s, matched 2 s, matched 3 s) + * let matched4 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s) + * let matched5 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s) + * let matched6 = fun s -> (matched 1 s, matched 2 s, matched 3 s, matched 4 s, matched 5 s, matched 6 s) + *) + + + +let split sep s = Str.split (Str.regexp sep) s +(* +let _ = example (split "/" "" =*= []) +let _ = example (split ":" ":a:b" =*= ["a";"b"]) +*) +let join sep xs = String.concat sep xs +(* +let _ = example (join "/" ["toto"; "titi"; "tata"] =$= "toto/titi/tata") +*) + +(* +let rec join str = function + | [] -> "" + | [x] -> x + | x::xs -> x ^ str ^ (join str xs) +*) + +let split_list_regexp_noheading = "__noheading__" + +let (split_list_regexp: string -> string list -> (string * string list) list) = + fun re xs -> + let rec split_lr_aux (heading, accu) = function + | [] -> [(heading, List.rev accu)] + | x::xs -> + if x =~ re + then (heading, List.rev accu)::split_lr_aux (x, []) xs + else split_lr_aux (heading, x::accu) xs + in + split_lr_aux ("__noheading__", []) xs + +> (fun xs -> if (List.hd xs) =*= ("__noheading__",[]) then List.tl xs else xs) + + + +let regexp_alpha = Str.regexp + "^[a-zA-Z_][A-Za-z_0-9]*$" + + +let all_match re s = + let regexp = Str.regexp re in + let res = ref [] in + let _ = Str.global_substitute regexp (fun _s -> + let substr = Str.matched_string s in + assert(substr ==~ regexp); (* @Effect: also use it's side effect *) + let paren_matched = matched1 substr in + push paren_matched res; + "" (* @Dummy *) + ) s in + List.rev !res + +(* +let _ = example (all_match "\\(@[A-Za-z]+\\)" "ca va @Et toi @Comment" + =*= ["@Et";"@Comment"]) +*) + +let global_replace_regexp re f_on_substr s = + let regexp = Str.regexp re in + Str.global_substitute regexp (fun _wholestr -> + + let substr = Str.matched_string s in + f_on_substr substr + ) s + + +let regexp_word_str = + "\\([a-zA-Z_][A-Za-z_0-9]*\\)" +let regexp_word = Str.regexp regexp_word_str + +let regular_words s = + all_match regexp_word_str s + +let contain_regular_word s = + let xs = regular_words s in + List.length xs >= 1 + + +(* This type allows to combine a serie of "regexps" to form a big + * one representing its union which should then be optimized by the Str + * module. + *) +type regexp = + | Contain of string + | Start of string + | End of string + | Exact of string + +let regexp_string_of_regexp x = + match x with + | Contain s -> ".*" ^ s ^ ".*" + | Start s -> "^" ^ s + | End s -> ".*" ^ s ^ "$" + | Exact s -> s + +let str_regexp_of_regexp x = + Str.regexp (regexp_string_of_regexp x) + +let compile_regexp_union xs = + xs +> List.map (fun x -> + regexp_string_of_regexp x + ) +> join "\\|" +> Str.regexp + + +(*****************************************************************************) +(* Strings *) +(*****************************************************************************) + +let slength = String.length +let concat = String.concat + +(* ruby *) +let i_to_s = string_of_int +let s_to_i = int_of_string + + +(* strings take space in memory. Better when can share the space used by + similar strings *) +let _shareds = Hashtbl.create 100 +let (shared_string: string -> string) = fun s -> + try Hashtbl.find _shareds s + with Not_found -> (Hashtbl.add _shareds s s; s) + +let chop = function + | "" -> "" + | s -> String.sub s 0 (String.length s - 1) + + +(* remove trailing / *) +let chop_dirsymbol = function + | s when s =~ "\\(.*\\)/$" -> matched1 s + | s -> s + + +let () s (i,j) = + String.sub s i (if j < 0 then String.length s - i + j + 1 else j - i) +(* let _ = example ( "tototati"(3,-2) = "otat" ) *) + +let () s i = String.get s i + +(* pixel *) +let rec split_on_char c s = + try + let sp = String.index s c in + String.sub s 0 sp :: + split_on_char c (String.sub s (sp+1) (String.length s - sp - 1)) + with Not_found -> [s] + + +let lowercase = String.lowercase + +let quote s = "\"" ^ s ^ "\"" +let unquote s = + if s =~ "\"\\(.*\\)\"" + then matched1 s + else failwith ("unquote: the string has no quote: " ^ s) + +(* easier to have this to be passed as hof, because ocaml dont have + * haskell "section" operators + *) +let null_string s = + s =$= "" + +let is_blank_string s = + s =~ "^\\([ \t]\\)*$" + +(* src: lablgtk2/examples/entrycompletion.ml *) +let is_string_prefix s1 s2 = + (String.length s1 <= String.length s2) && + (String.sub s2 0 (String.length s1) =$= s1) + +let plural i s = + if i =|= 1 + then Printf.sprintf "%d %s" i s + else Printf.sprintf "%d %ss" i s + +let showCodeHex xs = List.iter (fun i -> Printf.printf "%02x" i) xs + +let take_string n s = + String.sub s 0 (n-1) + +let take_string_safe n s = + if n > String.length s + then s + else take_string n s + + + +(* used by LFS *) +let size_mo_ko i = + let ko = (i / 1024) mod 1024 in + let mo = (i / 1024) / 1024 in + (if mo > 0 + then Printf.sprintf "%dMo%dKo" mo ko + else Printf.sprintf "%dKo" ko + ) + +let size_ko i = + let ko = i / 1024 in + Printf.sprintf "%dKo" ko + + + + + + +(* done in summer 2007 for julia + * Reference: P216 of gusfeld book + * For two strings S1 and S2, D(i,j) is defined to be the edit distance of S1[1..i] to S2[1..j] + * So edit distance of S1 (of length n) and S2 (of length m) is D(n,m) + * + * Dynamic programming technique + * base: + * D(i,0) = i for all i (cos to go from S1[1..i] to 0 characteres of S2 you have to delete all characters from S1[1..i] + * D(0,j) = j for all j (cos j characters must be inserted) + * recurrence: + * D(i,j) = min([D(i-1, j)+1, D(i, j - 1 + 1), D(i-1, j-1) + t(i,j)]) + * where t(i,j) is equal to 1 if S1(i) != S2(j) and 0 if equal + * intuition = there is 4 possible action = deletion, insertion, substitution, or match + * so Lemma = + * + * D(i,j) must be one of the three + * D(i, j-1) + 1 + * D(i-1, j)+1 + * D(i-1, j-1) + + * t(i,j) + * + * + *) +let matrix_distance s1 s2 = + let n = (String.length s1) in + let m = (String.length s2) in + let mat = Array.make_matrix (n+1) (m+1) 0 in + let t i j = + if String.get s1 (i-1) =<= String.get s2 (j-1) + then 0 + else 1 + in + let min3 a b c = min (min a b) c in + + begin + for i = 0 to n do + mat.(i).(0) <- i + done; + for j = 0 to m do + mat.(0).(j) <- j; + done; + for i = 1 to n do + for j = 1 to m do + mat.(i).(j) <- + min3 (mat.(i).(j-1) + 1) (mat.(i-1).(j) + 1) (mat.(i-1).(j-1) + t i j) + done + done; + mat + end +let edit_distance s1 s2 = + (matrix_distance s1 s2).(String.length s1).(String.length s2) + + +let test_edit = edit_distance "vintner" "writers" +let _ = assert (edit_distance "winter" "winter" =|= 0) +let _ = assert (edit_distance "vintner" "writers" =|= 5) + + +(* src: http://pleac.sourceforge.net/pleac_ocaml/strings.html *) +(* We can emulate the Perl wrap function with the following function *) +let wrap ?(width=80) s = + let l = Str.split (Str.regexp " ") s in + Format.pp_set_margin Format.str_formatter width; + Format.pp_open_box Format.str_formatter 0; + List.iter + (fun x -> + Format.pp_print_string Format.str_formatter x; + Format.pp_print_break Format.str_formatter 1 0;) l; + Format.flush_str_formatter ();; + +(*****************************************************************************) +(* Filenames *) +(*****************************************************************************) + +let dirname = Filename.dirname +let basename = Filename.basename + +type filename = string (* TODO could check that exist :) type sux *) + (* with sexp *) +type dirname = string (* TODO could check that exist :) type sux *) + (* with sexp *) + +(* file or dir *) +type path = string + +module BasicType = struct + type filename = string +end + + +(* updated: added '-' in filesuffix because of file like foo.c-- *) +let (filesuffix: filename -> string) = fun s -> + (try regexp_match s ".+\\.\\([a-zA-Z0-9_-]+\\)$" with _ -> "NOEXT") +let (fileprefix: filename -> string) = fun s -> + (try regexp_match s "\\(.+\\)\\.\\([a-zA-Z0-9_]+\\)?$" with _ -> s) + +(* +let _ = example (filesuffix "toto.c" =$= "c") +let _ = example (fileprefix "toto.c" =$= "toto") +*) + + +(* +assert (s = fileprefix s ^ filesuffix s) + +let withoutExtension s = global_replace (regexp "\\..*$") "" s +let () = example "without" + (withoutExtension "toto.s.toto" = "toto") +*) + +let adjust_ext_if_needed filename ext = + if String.get ext 0 <> '.' + then failwith "I need an extension such as .c not just c"; + + if not (filename =~ (".*\\" ^ ext)) + then filename ^ ext + else filename + + + +let db_of_filename file = + dirname file, basename file + +let filename_of_db (basedir, file) = + Filename.concat basedir file + + + +let dbe_of_filename file = + (* raise Invalid_argument if no ext, so safe to use later the unsafe + * fileprefix and filesuffix functions (well filesuffix is safe by default) + *) + ignore(Filename.chop_extension file); + Filename.dirname file, + Filename.basename file +> fileprefix, + Filename.basename file +> filesuffix + +let filename_of_dbe (dir, base, ext) = + if ext =$= "" + then Filename.concat dir base + else Filename.concat dir (base ^ "." ^ ext) + + +let dbe_of_filename_safe file = + try Left (dbe_of_filename file) + with Invalid_argument _ -> + Right (Filename.dirname file, Filename.basename file) + + +let dbe_of_filename_nodot file = + let (d,b,e) = dbe_of_filename file in + let d = if d =$= "." then "" else d in + d,b,e + + + + +(* old: + * let re_be = Str.regexp "\\([^.]*\\)\\.\\(.*\\)" + * let dbe_of_filename_noext_ok file = + * ... + * if Str.string_match re_be base 0 + * then + * let (b, e) = matched2 base in + * (dir, b, e) + * + * That way files like foo.md5sum.c would not be considered .c + * but .md5sum.c, but then it has too many disadvantages because + * then regular files like qemu.root.c would not be considered + * .c files, so it's better instead to fix syncweb to not generate + * .md5sum.c but .md5sum_c files! + *) + +let dbe_of_filename_noext_ok file = + let dir = Filename.dirname file in + let base = Filename.basename file in + dir, fileprefix base, filesuffix base + + +let replace_ext file oldext newext = + let (d,b,e) = dbe_of_filename file in + assert(e =$= oldext); + filename_of_dbe (d,b,newext) + + +let normalize_path file = + let (dir, filename) = Filename.dirname file, Filename.basename file in + let xs = split "/" dir in + let rec aux acc = function + | [] -> List.rev acc + | x::xs -> + (match x with + | "." -> aux acc xs + | ".." -> aux (List.tl acc) xs + | x -> aux (x::acc) xs + ) + in + let xs' = aux [] xs in + Filename.concat (join "/" xs') filename + + + +(* +let relative_to_absolute s = + if Filename.is_relative s + then + begin + let old = Sys.getcwd () in + Sys.chdir s; + let current = Sys.getcwd () in + Sys.chdir old; + s + end + else s +*) + +let relative_to_absolute s = + if s =$= "." + then Sys.getcwd () + else + if Filename.is_relative s + then Sys.getcwd () ^ "/" ^ s + else s + +let is_relative s = Filename.is_relative s +let is_absolute s = not (is_relative s) + + +(* pre: prj_path must not contain regexp symbol *) +let filename_without_leading_path prj_path s = + let prj_path = chop_dirsymbol prj_path in + if s =$= prj_path + then "." + else + if s =~ ("^" ^ prj_path ^ "/\\(.*\\)$") + then matched1 s + else + failwith + (spf "cant find filename_without_project_path: %s %s" prj_path s) + + +(* realpath: see end of file *) + +(* basic file position *) +type filepos = { + l: int; + c: int; +} + +(*****************************************************************************) +(* i18n *) +(*****************************************************************************) +type langage = + | English + | Francais + | Deutsch + +(* gettext ? *) + + +(*****************************************************************************) +(* Dates *) +(*****************************************************************************) + +(* maybe I should use ocamlcalendar, but I don't like all those functors ... *) + +type month = + | Jan | Feb | Mar | Apr | May | Jun + | Jul | Aug | Sep | Oct | Nov | Dec +type year = Year of int +type day = Day of int +type wday = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday + +type date_dmy = DMY of day * month * year + +type hour = Hour of int +type minute = Min of int +type second = Sec of int + +type time_hms = HMS of hour * minute * second + +type full_date = date_dmy * time_hms + + +(* intervalle *) +type days = Days of int + +type time_dmy = TimeDMY of day * month * year + + +type float_time = float + + + +let check_date_dmy (DMY (day, month, year)) = + raise Common.Todo + +let check_time_dmy (TimeDMY (day, month, year)) = + raise Common.Todo + +let check_time_hms (HMS (x,y,a)) = + raise Common.Todo + + + +(* ---------------------------------------------------------------------- *) + +(* older code *) +let int_to_month i = + assert (i <= 12 && i >= 1); + match i with + + | 1 -> "Jan" + | 2 -> "Feb" + | 3 -> "Mar" + | 4 -> "Apr" + | 5 -> "May" + | 6 -> "Jun" + | 7 -> "Jul" + | 8 -> "Aug" + | 9 -> "Sep" + | 10 -> "Oct" + | 11 -> "Nov" + | 12 -> "Dec" +(* + | 1 -> "January" + | 2 -> "February" + | 3 -> "March" + | 4 -> "April" + | 5 -> "May" + | 6 -> "June" + | 7 -> "July" + | 8 -> "August" + | 9 -> "September" + | 10 -> "October" + | 11 -> "November" + | 12 -> "December" +*) + | _ -> raise Common.Impossible + + +let month_info = [ + 1, Jan, "Jan", "January", 31; + 2, Feb, "Feb", "February", 28; + 3, Mar, "Mar", "March", 31; + 4, Apr, "Apr", "April", 30; + 5, May, "May", "May", 31; + 6, Jun, "Jun", "June", 30; + 7, Jul, "Jul", "July", 31; + 8, Aug, "Aug", "August", 31; + 9, Sep, "Sep", "September", 30; + 10, Oct, "Oct", "October", 31; + 11, Nov, "Nov", "November", 30; + 12, Dec, "Dec", "December", 31; +] + +let week_day_info = [ + 0, Sunday, "Sun", "Dim", "Sunday"; + 1, Monday, "Mon", "Lun", "Monday"; + 2, Tuesday, "Tue", "Mar", "Tuesday"; + 3, Wednesday, "Wed", "Mer", "Wednesday"; + 4, Thursday, "Thu","Jeu","Thursday"; + 5, Friday, "Fri", "Ven", "Friday"; + 6, Saturday, "Sat","Sam", "Saturday"; +] + +let i_to_month_h = + month_info +> List.map (fun (i,month,monthstr,mlong,days) -> i, month) +let s_to_month_h = + month_info +> List.map (fun (i,month,monthstr,mlong,days) -> monthstr, month) +let slong_to_month_h = + month_info +> List.map (fun (i,month,monthstr,mlong,days) -> mlong, month) +let month_to_s_h = + month_info +> List.map (fun (i,month,monthstr,mlong,days) -> month, monthstr) +let month_to_i_h = + month_info +> List.map (fun (i,month,monthstr,mlong,days) -> month, i) + +let i_to_wday_h = + week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> i, day) +let wday_to_en_h = + week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> day, dayen) +let wday_to_fr_h = + week_day_info +> List.map (fun (i,day,dayen,dayfr,daylong) -> day, dayfr) + +let month_of_string s = + List.assoc s s_to_month_h + +let month_of_string_long s = + List.assoc s slong_to_month_h + +let string_of_month s = + List.assoc s month_to_s_h + +let month_of_int i = + List.assoc i i_to_month_h + +let int_of_month m = + List.assoc m month_to_i_h + + +let wday_of_int i = + List.assoc i i_to_wday_h + +let string_en_of_wday wday = + List.assoc wday wday_to_en_h +let string_fr_of_wday wday = + List.assoc wday wday_to_fr_h + +(* ---------------------------------------------------------------------- *) + +let wday_str_of_int ~langage i = + let wday = wday_of_int i in + match langage with + | English -> string_en_of_wday wday + | Francais -> string_fr_of_wday wday + | Deutsch -> raise Common.Todo + + + +let string_of_date_dmy (DMY (Day n, month, Year y)) = + (spf "%02d-%s-%d" n (string_of_month month) y) + +let date_dmy_of_string s = + if s =~ "\\([0-9]+\\)-\\([A-Za-z]+\\)-\\([0-9]+\\)" + then + let (day, month, year) = matched3 s in + DMY (Day (int_of_string day), + month_of_string month, + Year (int_of_string year)) + else + failwith ("wrong dmy string: " ^ s) + +let string_of_unix_time ?(langage=English) tm = + let y = tm.Unix.tm_year + 1900 in + let mon = string_of_month (month_of_int (tm.Unix.tm_mon + 1)) in + let d = tm.Unix.tm_mday in + let h = tm.Unix.tm_hour in + let min = tm.Unix.tm_min in + let s = tm.Unix.tm_sec in + + let wday = wday_str_of_int ~langage tm.Unix.tm_wday in + + spf "%02d/%3s/%04d (%s) %02d:%02d:%02d" d mon y wday h min s + +(* ex: 21/Jul/2008 (Lun) 21:25:12 *) +let unix_time_of_string s = + if s =~ + ("\\([0-9][0-9]\\)/\\(...\\)/\\([0-9][0-9][0-9][0-9]\\) " ^ + "\\(.*\\) \\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)") + then + let (sday, smonth, syear, _sday, shour, smin, ssec) = matched7 s in + + let y = s_to_i syear - 1900 in + let mon = + smonth +> month_of_string +> int_of_month +> (fun i -> i -1) + in + + let tm = Unix.localtime (Unix.time ()) in + { tm with + Unix.tm_year = y; + Unix.tm_mon = mon; + Unix.tm_mday = s_to_i sday; + Unix.tm_hour = s_to_i shour; + Unix.tm_min = s_to_i smin; + Unix.tm_sec = s_to_i ssec; + } + else failwith ("unix_time_of_string: " ^ s) + + + +let short_string_of_unix_time ?(langage=English) tm = + let y = tm.Unix.tm_year + 1900 in + let mon = string_of_month (month_of_int (tm.Unix.tm_mon + 1)) in + let d = tm.Unix.tm_mday in + let _h = tm.Unix.tm_hour in + let _min = tm.Unix.tm_min in + let _s = tm.Unix.tm_sec in + + let wday = wday_str_of_int ~langage tm.Unix.tm_wday in + + spf "%02d/%3s/%04d (%s)" d mon y wday + + +let string_of_unix_time_lfs time = + spf "%02d--%s--%d" + time.Unix.tm_mday + (int_to_month (time.Unix.tm_mon + 1)) + (time.Unix.tm_year + 1900) + + +(* ---------------------------------------------------------------------- *) +let string_of_floattime ?langage i = + let tm = Unix.localtime i in + string_of_unix_time ?langage tm + +let short_string_of_floattime ?langage i = + let tm = Unix.localtime i in + short_string_of_unix_time ?langage tm + +let floattime_of_string s = + let tm = unix_time_of_string s in + let (sec,_tm) = Unix.mktime tm in + sec + + +(* ---------------------------------------------------------------------- *) +let days_in_week_of_day day = + let tm = Unix.localtime day in + + let wday = tm.Unix.tm_wday in + let wday = if wday =|= 0 then 6 else wday -1 in + + let mday = tm.Unix.tm_mday in + + let start_d = mday - wday in + let end_d = mday + (6 - wday) in + + enum start_d end_d +> List.map (fun mday -> + Unix.mktime {tm with Unix.tm_mday = mday} +> fst + ) + +let first_day_in_week_of_day day = + List.hd (days_in_week_of_day day) + +let last_day_in_week_of_day day = + list_last (days_in_week_of_day day) + + +(* ---------------------------------------------------------------------- *) + +(* (modified) copy paste from ocamlcalendar/src/date.ml *) +let days_month = + [| 0; 31; 59; 90; 120; 151; 181; 212; 243; 273; 304; 334(*; 365*) |] + + +let rough_days_since_jesus (DMY (Day nday, month, Year year)) = + let n = + nday + + (days_month.(int_of_month month -1)) + + year * 365 + in + Days n + + + +let is_more_recent d1 d2 = + let (Days n1) = rough_days_since_jesus d1 in + let (Days n2) = rough_days_since_jesus d2 in + (n1 > n2) + + +let max_dmy d1 d2 = + if is_more_recent d1 d2 + then d1 + else d2 + +let min_dmy d1 d2 = + if is_more_recent d1 d2 + then d2 + else d1 + + +let maximum_dmy ds = + foldl1 max_dmy ds + +let minimum_dmy ds = + foldl1 min_dmy ds + + + +let rough_days_between_dates d1 d2 = + let (Days n1) = rough_days_since_jesus d1 in + let (Days n2) = rough_days_since_jesus d2 in + Days (n2 - n1) + +let _ = assert + (rough_days_between_dates + (DMY (Day 7, Jan, Year 1977)) + (DMY (Day 13, Jan, Year 1977)) =*= Days 6) + +(* because of rough days, it is a bit buggy, here it should return 1 *) +(* +let _ = assert_equal + (rough_days_between_dates + (DMY (Day 29, Feb, Year 1977)) + (DMY (Day 1, Mar , Year 1977))) + (Days 1) +*) + + +(* from julia, in gitsort.ml *) + +(* +let antimonths = + [(1,31);(2,28);(3,31);(4,30);(5,31); (6,6);(7,7);(8,31);(9,30);(10,31); + (11,30);(12,31);(0,31)] + +let normalize (year,month,day,hour,minute,second) = + if hour < 0 + then + let (day,hour) = (day - 1,hour + 24) in + if day = 0 + then + let month = month - 1 in + let day = List.assoc month antimonths in + let day = + if month = 2 && year / 4 * 4 = year && not (year / 100 * 100 = year) + then 29 + else day in + if month = 0 + then (year-1,12,day,hour,minute,second) + else (year,month,day,hour,minute,second) + else (year,month,day,hour,minute,second) + else (year,month,day,hour,minute,second) + +*) + + +let mk_date_dmy day month year = + let date = DMY (Day day, month_of_int month, Year year) in + (* check_date_dmy date *) + date + + +(* ---------------------------------------------------------------------- *) +(* conversion to unix.tm *) + +let dmy_to_unixtime (DMY (Day n, month, Year year)) = + let tm = { + Unix.tm_sec = 0; (** Seconds 0..60 *) + tm_min = 0; (** Minutes 0..59 *) + tm_hour = 12; (** Hours 0..23 *) + tm_mday = n; (** Day of month 1..31 *) + tm_mon = (int_of_month month -1); (** Month of year 0..11 *) + tm_year = year - 1900; (** Year - 1900 *) + tm_wday = 0; (** Day of week (Sunday is 0) *) + tm_yday = 0; (** Day of year 0..365 *) + tm_isdst = false; (** Daylight time savings in effect *) + } in + Unix.mktime tm + +let unixtime_to_dmy tm = + let n = tm.Unix.tm_mday in + let month = month_of_int (tm.Unix.tm_mon + 1) in + let year = tm.Unix.tm_year + 1900 in + + DMY (Day n, month, Year year) + + +let unixtime_to_floattime tm = + Unix.mktime tm +> fst + +let floattime_to_unixtime sec = + Unix.localtime sec + +let floattime_to_dmy sec = + sec +> floattime_to_unixtime +> unixtime_to_dmy + + +let sec_to_days sec = + let minfactor = 60 in + let hourfactor = 60 * 60 in + let dayfactor = 60 * 60 * 24 in + + let days = sec / dayfactor in + let hours = (sec mod dayfactor) / hourfactor in + let mins = (sec mod hourfactor) / minfactor in + let sec = (sec mod 60) in + (* old: Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *) + (if days > 0 then plural days "day" ^ " " else "") ^ + (if hours > 0 then plural hours "hour" ^ " " else "") ^ + (if mins > 0 then plural mins "min" ^ " " else "") ^ + (spf "%dsec" sec) + +let sec_to_hours sec = + let minfactor = 60 in + let hourfactor = 60 * 60 in + + let hours = sec / hourfactor in + let mins = (sec mod hourfactor) / minfactor in + let sec = (sec mod 60) in + (* old: Printf.sprintf "%d days, %d hours, %d minutes" days hours mins *) + (if hours > 0 then plural hours "hour" ^ " " else "") ^ + (if mins > 0 then plural mins "min" ^ " " else "") ^ + (spf "%dsec" sec) + + + +let test_date_1 () = + let date = DMY (Day 17, Sep, Year 1991) in + let float, tm = dmy_to_unixtime date in + pr2 (spf "date: %.0f" float); + () + + +(* src: ferre in logfun/.../date.ml *) + +let day_secs : float = 86400. + +let today : unit -> float = fun () -> (Unix.time () ) +let yesterday : unit -> float = fun () -> (Unix.time () -. day_secs) +let tomorrow : unit -> float = fun () -> (Unix.time () +. day_secs) + +let lastweek : unit -> float = fun () -> (Unix.time () -. (7.0 *. day_secs)) +let lastmonth : unit -> float = fun () -> (Unix.time () -. (30.0 *. day_secs)) + + +let week_before : float_time -> float_time = fun d -> + (d -. (7.0 *. day_secs)) +let month_before : float_time -> float_time = fun d -> + (d -. (30.0 *. day_secs)) + +let week_after : float_time -> float_time = fun d -> + (d +. (7.0 *. day_secs)) + +let timestamp () = + let now = Unix.time () in + let tm = floattime_to_unixtime now in + + let d = tm.Unix.tm_mday in + let h = tm.Unix.tm_hour in + let min = tm.Unix.tm_min in + let s = tm.Unix.tm_sec in + (* old: string_of_unix_time tm *) + spf "%02d %02d:%02d:%02d" d h min s + + +(*****************************************************************************) +(* Lines/words/strings *) +(*****************************************************************************) + +(* now in prelude: + * let (list_of_string: string -> char list) = fun s -> + * (enum 0 ((String.length s) - 1) +> List.map (String.get s)) + *) + +let _ = assert (list_of_string "abcd" =*= ['a';'b';'c';'d']) + +(* +let rec (list_of_stream: ('a Stream.t) -> 'a list) = +parser + | [< 'c ; stream >] -> c :: list_of_stream stream + | [<>] -> [] + +let (list_of_string: string -> char list) = + Stream.of_string $ list_of_stream +*) + +(* now in prelude: + * let (lines: string -> string list) = fun s -> ... + *) + +let (lines_with_nl: string -> string list) = fun s -> + let rec lines_aux = function + | [] -> [] + | [x] -> if x =$= "" then [] else [x ^ "\n"] (* old: [x] *) + | x::xs -> + let e = x ^ "\n" in + e::lines_aux xs + in + (time_func (fun () -> Str.split_delim (Str.regexp "\n") s)) +> lines_aux + +(* in fact better make it return always complete lines, simplify *) +(* Str.split, but lines "\n1\n2\n" dont return the \n and forget the first \n => split_delim better than split *) +(* +> List.map (fun s -> s ^ "\n") but add an \n even at the end => lines_aux *) +(* old: slow + let chars = list_of_string s in + chars +> List.fold_left (fun (acc, lines) char -> + let newacc = acc ^ (String.make 1 char) in + if char = '\n' + then ("", newacc::lines) + else (newacc, lines) + ) ("", []) + +> (fun (s, lines) -> List.rev (s::lines)) +*) + +(* CHECK: unlines (lines x) = x *) +let (unlines: string list -> string) = fun s -> + (String.concat "\n" s) ^ "\n" +let (words: string -> string list) = fun s -> + Str.split (Str.regexp "[ \t()\";]+") s +let (unwords: string list -> string) = fun s -> + String.concat "" s + +let (split_space: string -> string list) = fun s -> + Str.split (Str.regexp "[ \t\n]+") s + +let n_space n = repeat " " n +> join "" + +let indent_string n s = + let xs = lines s in + xs + +> List.map (fun s -> n_space n ^ s) + +> unlines + + +(* todo opti ? *) +let nblines s = + lines s +> List.length +(* +let _ = example (nblines "" =|= 0) +let _ = example (nblines "toto" =|= 1) +let _ = example (nblines "toto\n" =|= 1) +let _ = example (nblines "toto\ntata" =|= 2) +let _ = example (nblines "toto\ntata\n" =|= 2) +*) + +(* old: fork sucks. + * (* note: on MacOS wc outputs some spaces before the number of lines *) + *) + + +let nblines_eff2 file = + let res = ref 0 in + let finished = ref false in + let ch = open_in file in + while not !finished do + try + let _ = input_line ch in + incr res + with End_of_file -> finished := true + done; + close_in ch; + !res +let nblines_eff a = + Common.profile_code "Nblines_eff" (fun () -> nblines_eff2 a) + + + + +(* could be in h_files-format *) +let words_of_string_with_newlines s = + lines s +> List.map words +> List.flatten +> exclude null_string + +let lines_with_nl_either s = + let xs = Str.full_split (Str.regexp "\n") s in + xs +> List.map (function + | Str.Delim s -> Right () + | Str.Text s -> Left s + ) + +(* +let _ = example (lines_with_nl_either "ab\n\nc" =*= + [Left "ab"; Right (); Right (); Left "c"]) +*) + +(*****************************************************************************) +(* Process/Files *) +(*****************************************************************************) +let cat_orig file = + let chan = open_in file in + let rec cat_orig_aux () = + try + (* cant do input_line chan::aux() cos ocaml eval from right to left ! *) + let l = input_line chan in + l :: cat_orig_aux () + with End_of_file -> [] in + cat_orig_aux() + +(* tail recursive efficient version *) +let cat file = + let chan = open_in file in + let rec cat_aux acc () = + (* cant do input_line chan::aux() cos ocaml eval from right to left ! *) + let (b, l) = try (true, input_line chan) with End_of_file -> (false, "") in + if b + then cat_aux (l::acc) () + else acc + in + cat_aux [] () +> List.rev +> (fun x -> close_in chan; x) + +let cat_array file = + (""::cat file) +> Array.of_list + +(* Spec for cat_excerpts: +let cat_excerpts file lines = + let arr = cat_array file in + lines |> List.map (fun i -> arr.(i)) +*) + +let cat_excerpts file lines = Common.with_open_infile file (fun chan -> + let lines = List.sort compare lines in + let rec aux acc lines count = + let (b,l) = try (true, input_line chan) with End_of_file -> (false, "") in + if (not b) then acc else + match lines with + | [] -> acc + | c::cdr when (c==count) -> aux (l::acc) cdr (count+1) + | _ -> aux acc lines (count+1) + in + aux [] lines 1 +> List.rev) + +let interpolate str = + begin + command2 ("printf \"%s\\n\" " ^ str ^ ">/tmp/caml"); + cat "/tmp/caml" + end + +(* could do a print_string but printf dont like print_string *) +let echo s = Printf.printf "%s" s; flush stdout; s + +let usleep s = for i = 1 to s do () done + +let sleep_little () = + (*old: *) + Unix.sleep 1 + (*ignore(Sys.command ("usleep " ^ !_sleep_time))*) + + +(* now in prelude: + * let command2 s = ignore(Sys.command s) + *) + +let do_in_fork f = + let pid = Unix.fork () in + if pid =|= 0 + then + begin + (* Unix.setsid(); *) + Sys.set_signal Sys.sigint (Sys.Signal_handle (fun _ -> + pr2 "being killed"; + Unix.kill 0 Sys.sigkill; + )); + f (); + exit 0; + end + else pid + + +exception CmdError of Unix.process_status * string + +let process_output_to_list2 ?(verbose=false) command = + let chan = Unix.open_process_in command in + let res = ref ([] : string list) in + let rec process_otl_aux () = + let e = input_line chan in + res := e::!res; + if verbose then pr2 e; + process_otl_aux() in + try process_otl_aux () + with End_of_file -> + let stat = Unix.close_process_in chan in (List.rev !res,stat) +let cmd_to_list ?verbose command = + let (l,exit_status) = process_output_to_list2 ?verbose command in + match exit_status with + | Unix.WEXITED 0 -> l + | _ -> raise (CmdError (exit_status, + (spf "CMD = %s, RESULT = %s" + command (String.concat "\n" l)))) + +let process_output_to_list = cmd_to_list +let cmd_to_list_and_status = process_output_to_list2 + +let nblines_with_wc2 file = + match cmd_to_list (spf "wc -l %s" file) with + | [s] when s =~ "^[ \t]*\\([0-9]+\\) " -> s_to_i (matched1 s) + | _ -> failwith "pb in output of wc" +let nblines_with_wc a = + Common.profile_code "Common.nblines_with_wc" (fun () -> nblines_eff2 a) + +let unix_diff file1 file2 = + let (xs, _status) = + cmd_to_list_and_status (spf "diff -u %s %s" file1 file2) in + xs +(* see also unix_diff_strings at the bottom *) + +let get_mem() = + cmd_to_list("grep VmData /proc/" ^ string_of_int (Unix.getpid()) ^ "/status") + +> join "" + +(* now in prelude: + * let command2 s = ignore(Sys.command s) + *) + +let _batch_mode = ref false + +let y_or_no msg = + pr2 (msg ^ " [y/n] ?"); + if !_batch_mode then true + else begin + let rec aux () = + match read_line () with + | "y" | "yes" | "Y" -> true + | "n" | "no" | "N" -> false + | _ -> + pr2 "answer by 'y' or 'n'"; + aux () + in + aux () + end + +let command2_y_or_no cmd = + if !_batch_mode then begin command2 cmd; true end + else begin + + pr2 (cmd ^ " [y/n] ?"); + match read_line () with + | "y" | "yes" | "Y" -> command2 cmd; true + | "n" | "no" | "N" -> false + | _ -> failwith "answer by yes or no" + end + +let command2_y_or_no_exit_if_no cmd = + let res = command2_y_or_no cmd in + if res + then () + else raise (UnixExit (1)) + +let command_safe ?(verbose=false) program args = + let pid = Unix.fork () in + let cmd_str = (program::args) +> join " " in + if pid =|= 0 then begin + pr2 ("running: " ^ cmd_str); + Unix.execv program (Array.of_list (program::args)) + end + else + let (pid2, status) = Unix.waitpid [] pid in + match status with + | Unix.WEXITED retcode -> retcode + | Unix.WSIGNALED _ | Unix.WSTOPPED _ -> + failwith ("problem running: " ^ cmd_str) + + + +let mkdir ?(mode=0o770) file = + Unix.mkdir file mode + +let read_file_orig file = cat file +> unlines +let read_file file = + let ic = open_in file in + let size = in_channel_length ic in + let buf = String.create size in + really_input ic buf 0 size; + close_in ic; + buf + + +let write_file ~file s = + let chan = open_out file in + (output_string chan s; close_out chan) + +let unix_stat file = + Common.profile_code "Unix.stat" (fun () -> + Unix.stat file + ) + +let filesize file = + (unix_stat file).Unix.st_size + +let filemtime file = + (unix_stat file).Unix.st_mtime + +(* opti? use wc -l ? *) +let nblines_file file = + cat file +> List.length + +let lfile_exists filename = + try + (match (Unix.lstat filename).Unix.st_kind with + | (Unix.S_REG | Unix.S_LNK) -> true + | _ -> false + ) + with Unix.Unix_error (Unix.ENOENT, _, _) -> false + +let is_directory file = + (unix_stat file).Unix.st_kind =*= Unix.S_DIR +let is_file file = + (unix_stat file).Unix.st_kind =*= Unix.S_REG +let is_symlink file = + (Unix.lstat file).Unix.st_kind =*= Unix.S_LNK + +let is_executable file = + let stat = unix_stat file in + let perms = stat.Unix.st_perm in + stat.Unix.st_kind =*= Unix.S_REG && + (perms land 0o011 <> 0) + + +(* ---------------------------------------------------------------------- *) +(* _eff variant *) +(* ---------------------------------------------------------------------- *) +let _hmemo_unix_lstat_eff = Hashtbl.create 101 +let _hmemo_unix_stat_eff = Hashtbl.create 101 + +let unix_lstat_eff file = + Common.profile_code "Unix.lstat_eff" (fun () -> + if is_absolute file + then + memoized _hmemo_unix_lstat_eff file (fun () -> + Unix.lstat file + ) + else + (* this is for efficieny reason to be able to memoize the stats *) + failwith "must pass absolute path to unix_lstat_eff" + ) + +let unix_stat_eff file = + Common.profile_code "Unix.stat_eff" (fun () -> + if is_absolute file + then + memoized _hmemo_unix_stat_eff file (fun () -> + Unix.stat file + ) + else + (* this is for efficieny reason to be able to memoize the stats *) + failwith "must pass absolute path to unix_stat_eff" + ) + +let filesize_eff file = + (unix_lstat_eff file).Unix.st_size + +let filemtime_eff file = + (unix_lstat_eff file).Unix.st_mtime + +let lfile_exists_eff filename = + try + (match (unix_lstat_eff filename).Unix.st_kind with + | (Unix.S_REG | Unix.S_LNK) -> true + | _ -> false + ) + with Unix.Unix_error (Unix.ENOENT, _, _) -> false + +let is_directory_eff file = + (unix_lstat_eff file).Unix.st_kind =*= Unix.S_DIR +let is_file_eff file = + (unix_lstat_eff file).Unix.st_kind =*= Unix.S_REG + +let is_executable_eff file = + let stat = unix_lstat_eff file in + let perms = stat.Unix.st_perm in + stat.Unix.st_kind =*= Unix.S_REG && + (perms land 0o011 <> 0) + + +(* ---------------------------------------------------------------------- *) + +(* src: from chailloux et al book *) +let capsule_unix f args = + try (f args) + with Unix.Unix_error (e, fm, argm) -> + log (Printf.sprintf "exn Unix_error: %s %s %s\n" (Unix.error_message e) fm argm) + + +let (readdir_to_kind_list: string -> Unix.file_kind -> string list) = + fun path kind -> + Sys.readdir path + +> Array.to_list + +> List.filter (fun s -> + try + let stat = Unix.lstat (path ^ "/" ^ s) in + stat.Unix.st_kind =*= kind + with e -> + pr2 ("EXN pb stating file: " ^ s); + false + ) + +let (readdir_to_dir_list: string -> string list) = fun path -> + readdir_to_kind_list path Unix.S_DIR + +let (readdir_to_file_list: string -> string list) = fun path -> + readdir_to_kind_list path Unix.S_REG + +let (readdir_to_link_list: string -> string list) = fun path -> + readdir_to_kind_list path Unix.S_LNK + + +let (readdir_to_dir_size_list: string -> (string * int) list) = fun path -> + Sys.readdir path + +> Array.to_list + +> map_filter (fun s -> + let stat = Unix.lstat (path ^ "/" ^ s) in + if stat.Unix.st_kind =*= Unix.S_DIR + then Some (s, stat.Unix.st_size) + else None + ) + +let unixname () = + let uid = Unix.getuid () in + let entry = Unix.getpwuid uid in + entry.Unix.pw_name + + +(* could be in control section too *) + +(* Why a use_cache argument ? because sometimes want disable it but dont + * want put the cache_computation funcall in comment, so just easier to + * pass this extra option. + *) +let cache_computation2 ?(verbose=false) ?(use_cache=true) file ext_cache f = + if not use_cache + then f () + else begin + if not (Sys.file_exists file) + then begin + pr2 ("WARNING: cache_computation: can't find file " ^ file); + pr2 ("defaulting to calling the function"); + f () + end else begin + let file_cache = (file ^ ext_cache) in + if Sys.file_exists file_cache && + filemtime file_cache >= filemtime file + then begin + if verbose then pr2 ("using cache: " ^ file_cache); + get_value file_cache + end + else begin + let res = f () in + write_value res file_cache; + res + end + end + end +let cache_computation ?verbose ?use_cache a b c = + Common.profile_code "Common.cache_computation" (fun () -> + cache_computation2 ?verbose ?use_cache a b c) + + +let cache_computation_robust2 + file ext_cache + (need_no_changed_files, need_no_changed_variables) ext_depend + f = + if not (Sys.file_exists file) + then failwith ("can't find: " ^ file); + + let file_cache = (file ^ ext_cache) in + let dependencies_cache = (file ^ ext_depend) in + + let dependencies = + (* could do md5sum too *) + ((file::need_no_changed_files) +> List.map (fun f -> f, filemtime f), + need_no_changed_variables) + in + + if Sys.file_exists dependencies_cache && + get_value dependencies_cache =*= dependencies + then get_value file_cache + else begin + pr2 ("cache computation recompute " ^ file); + let res = f () in + write_value dependencies dependencies_cache; + write_value res file_cache; + res + end + +let cache_computation_robust a b c d e = + Common.profile_code "Common.cache_computation_robust" (fun () -> + cache_computation_robust2 a b c d e) + + + + +(* dont forget that cmd_to_list call bash and so pattern may contain + * '*' symbols that will be expanded, so can do glob "*.c" + *) +let glob pattern = + cmd_to_list ("ls -1 " ^ pattern) + +let dirs_of_dir dir = + assert(is_directory dir); + let xs = cmd_to_list (spf "find \"%s\" -type d" dir) in + match xs with + | [] -> failwith ("dirs_of_dir: pb with" ^ dir) + | x::xs -> xs + + +(* TODO: do a files_of_dir_or_files ?no_vcs ?filter:Ext|Reg|Filter +*) + +(* update: have added the -type f, so normally need less the sanity_check_xxx + * function below *) +let files_of_dir_or_files ext xs = + xs +> List.map (fun x -> + if is_directory x + then cmd_to_list ("find " ^ x ^" -noleaf -type f -name \"*." ^ext^"\"") + else [x] + ) +> List.concat + + +let grep_dash_v_str = + "| grep -v /.hg/ |grep -v /CVS/ | grep -v /.git/ |grep -v /_darcs/" ^ + "| grep -v /.svn/ | grep -v .git_annot | grep -v .marshall" + +let arg_symlink () = + if !Common.follow_symlinks + then " -L " + else "" + + +let files_of_dir_or_files_no_vcs ext xs = + xs +> List.map (fun x -> + if is_directory x + then + cmd_to_list + ("find "^arg_symlink()^x^ " -noleaf -type f -name \"*." ^ext^"\"" ^ + grep_dash_v_str + ) + else [x] + ) +> List.concat + + +let files_of_dir_or_files_no_vcs_nofilter xs = + xs +> List.map (fun x -> + if is_directory x + then + cmd_to_list_and_status + ("find "^arg_symlink()^x^" -noleaf -type f " ^ + grep_dash_v_str + ) +> fst + else [x] + ) +> List.concat + + +let files_of_dir_or_files_no_vcs_post_filter regex xs = + xs +> List.map (fun x -> + if is_directory x + then + cmd_to_list + ("find "^arg_symlink()^x^ + " -noleaf -type f " ^ grep_dash_v_str + ) + +> List.filter (fun s -> s =~ regex) + else [x] + ) +> List.concat + + +let sanity_check_files_and_adjust ext files = + let files = files +> List.filter (fun file -> + if not (file =~ (".*\\."^ext)) + then begin + pr2 ("warning: seems not a ."^ext^" file"); + false + end + else + if is_directory file + then begin + pr2 (spf "warning: %s is a directory" file); + false + end + else true + ) in + files + + + + +(* taken from mlfuse, the predecessor of ocamlfuse *) +type rwx = [`R|`W|`X] list +let file_perm_of : u:rwx -> g:rwx -> o:rwx -> Unix.file_perm = + fun ~u ~g ~o -> + let to_oct l = + List.fold_left (fun acc p -> acc lor ((function `R -> 4 | `W -> 2 | `X -> 1) p)) 0 l in + let perm = + ((to_oct u) lsl 6) lor + ((to_oct g) lsl 3) lor + (to_oct o) + in + perm + + +(* pixel *) +let has_env var = + failwith "Common.has_env, TODO" +(* + try + let _ = Sys.getenv var in true + with Not_found -> false +*) + + +let (with_open_outfile_append: filename -> (((string -> unit) * out_channel) -> 'a) -> 'a) = + fun file f -> + let chan = open_out_gen [Open_creat;Open_append] 0o666 file in + let pr s = output_string chan s in + Common.unwind_protect (fun () -> + let res = f (pr, chan) in + close_out chan; + res) + (fun e -> close_out chan) + + +(* now in prelude: + * exception Timeout + *) + +(* it seems that the toplevel block such signals, even with this explicit + * command :( + * let _ = Unix.sigprocmask Unix.SIG_UNBLOCK [Sys.sigalrm] + *) + +(* could be in Control section *) + +(* subtil: have to make sure that timeout is not intercepted before here, so + * avoid exn handle such as try (...) with _ -> cos timeout will not bubble up + * enough. In such case, add a case before such as + * with Timeout -> raise Timeout | _ -> ... + * + * question: can we have a signal and so exn when in a exn handler ? + *) +let timeout_function ?(verbose=false) timeoutval = fun f -> + try + begin + Sys.set_signal Sys.sigalrm (Sys.Signal_handle (fun _ -> raise Timeout )); + ignore(Unix.alarm timeoutval); + let x = f () in + ignore(Unix.alarm 0); + x + end + with Timeout -> + begin + if verbose then log "timeout (we abort)"; + raise Timeout; + end + | e -> + (* subtil: important to disable the alarm before relaunching the exn, + * otherwise the alarm is still running. + * + * robust?: and if alarm launched after the log (...) ? + * Maybe signals are disabled when process an exception handler ? + *) + begin + ignore(Unix.alarm 0); + (* log ("exn while in transaction (we abort too, even if ...) = " ^ + Printexc.to_string e); + *) + if verbose then log "exn while in timeout_function"; + raise e + end + +let timeout_function_opt timeoutvalopt f = + match timeoutvalopt with + | None -> f () + | Some x -> timeout_function x f + + +let with_tmp_file ~str ~ext f = + let tmpfile = Common.new_temp_file "tmp" ("." ^ ext) in + write_file ~file:tmpfile str; + f tmpfile + +let with_tmp_dir f = + let tmp_dir = Filename.temp_file (spf "with-tmp-dir-%d" (Unix.getpid())) "" in + Unix.unlink tmp_dir; + (* who cares about race *) + Unix.mkdir tmp_dir 0o755; + Common.finalize (fun () -> + f tmp_dir + ) (fun () -> + command2 (spf "rm -f %s/*" tmp_dir); + Unix.rmdir tmp_dir + ) + + + +(* now in prelude: exception UnixExit of int *) +let exn_to_real_unixexit f = + try f () + with UnixExit x -> exit x + + + +let uncat xs file = + Common.with_open_outfile file (fun (pr,_chan) -> + xs +> List.iter (fun s -> pr s; pr "\n"); + + ) + +(*###########################################################################*) +(* Collection-like types *) +(*###########################################################################*) + +(*x: common.ml *) +(*****************************************************************************) +(* List *) +(*****************************************************************************) + +(* pixel *) +let uncons l = (List.hd l, List.tl l) + +(* pixel *) +let safe_tl l = try List.tl l with _ -> [] + +(* in prelude +let push l v = + l := v :: !l +*) + +let rec zip xs ys = + match (xs,ys) with + | ([],[]) -> [] + | ([],_) -> failwith "zip: not same length" + | (_,[]) -> failwith "zip: not same length" + | (x::xs,y::ys) -> (x,y)::zip xs ys + +let rec zip_safe xs ys = + match (xs,ys) with + | ([],_) -> [] + | (_,[]) -> [] + | (x::xs,y::ys) -> (x,y)::zip_safe xs ys + +let rec unzip zs = + List.fold_right (fun e (xs, ys) -> + (fst e::xs), (snd e::ys)) zs ([],[]) + + +let map_withkeep f xs = + xs +> List.map (fun x -> f x, x) + +(* now in prelude + * let rec take n xs = + * match (n,xs) with + * | (0,_) -> [] + * | (_,[]) -> failwith "take: not enough" + * | (n,x::xs) -> x::take (n-1) xs + *) + +let rec take_safe n xs = + match (n,xs) with + | (0,_) -> [] + | (_,[]) -> [] + | (n,x::xs) -> x::take_safe (n-1) xs + +let rec take_until p = function + | [] -> [] + | x::xs -> if p x then [] else x::(take_until p xs) + +let take_while p = take_until (p $ not) + + +(* now in prelude: let rec drop n xs = ... *) +let _ = assert (drop 3 [1;2;3;4] =*= [4]) + +let rec drop_while p = function + | [] -> [] + | x::xs -> if p x then drop_while p xs else x::xs + + +let rec drop_until p xs = + drop_while (fun x -> not (p x)) xs +let _ = assert (drop_until (fun x -> x =|= 3) [1;2;3;4;5] =*= [3;4;5]) + + +let span p xs = (take_while p xs, drop_while p xs) + + +let rec (span: ('a -> bool) -> 'a list -> 'a list * 'a list) = + fun p -> function + | [] -> ([], []) + | x::xs -> + if p x then + let (l1, l2) = span p xs in + (x::l1, l2) + else ([], x::xs) +let _ = assert ((span (fun x -> x <= 3) [1;2;3;4;1;2] =*= ([1;2;3],[4;1;2]))) + +let rec (span_tail_call: ('a -> bool) -> 'a list -> 'a list * 'a list) = + fun p xs -> + let rec aux acc xs = + match xs with + | [] -> (List.rev acc, []) + | x::xs -> + if p x then + aux (x::acc) xs + else + (List.rev acc, x::xs) + in + aux [] xs +let _ = assert ( + (span_tail_call (fun x -> x <= 3) [1;2;3;4;1;2] =*= ([1;2;3],[4;1;2])) + ) + +let rec groupBy eq l = + match l with + | [] -> [] + | x::xs -> + let (xs1,xs2) = List.partition (fun x' -> eq x x') xs in + (x::xs1)::(groupBy eq xs2) + +(* you should really use group_assoc_bykey_eff *) +let rec group_by_mapped_key fkey l = + match l with + | [] -> [] + | x::xs -> + let k = fkey x in + let (xs1,xs2) = List.partition (fun x' -> let k2 = fkey x' in k=*=k2) xs + in + (k, (x::xs1))::(group_by_mapped_key fkey xs2) + + +let group_and_count xs = + xs + +> groupBy (=*=) + +> List.map (fun xs -> + match xs with + | x::rest -> x, List.length xs + | [] -> raise Common.Impossible + ) + + +let (exclude_but_keep_attached: ('a -> bool) -> 'a list -> ('a * 'a list) list)= + fun f xs -> + let rec aux_filter acc = function + | [] -> [] (* drop what was accumulated because nothing to attach to *) + | x::xs -> + if f x + then aux_filter (x::acc) xs + else (x, List.rev acc)::aux_filter [] xs + in + aux_filter [] xs +let _ = assert + (exclude_but_keep_attached (fun x -> x =|= 3) [3;3;1;3;2;3;3;3] =*= + [(1,[3;3]);(2,[3])]) + +let (group_by_post: ('a -> bool) -> 'a list -> ('a list * 'a) list * 'a list)= + fun f xs -> + let rec aux_filter grouped_acc acc = function + | [] -> + List.rev grouped_acc, List.rev acc + | x::xs -> + if f x + then + aux_filter ((List.rev acc,x)::grouped_acc) [] xs + else + aux_filter grouped_acc (x::acc) xs + in + aux_filter [] [] xs + +let _ = assert + (group_by_post (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*= + ([([1;1],3);([2],3);[4;5],3], [6;6;6])) + +let (group_by_pre: ('a -> bool) -> 'a list -> 'a list * ('a * 'a list) list)= + fun f xs -> + let xs' = List.rev xs in + let (ys, unclassified) = group_by_post f xs' in + List.rev unclassified, + ys +> List.rev +> List.map (fun (xs, x) -> x, List.rev xs ) + +let _ = assert + (group_by_pre (fun x -> x =|= 3) [1;1;3;2;3;4;5;3;6;6;6] =*= + ([1;1], [(3,[2]); (3,[4;5]); (3,[6;6;6])])) + + +let rec (split_when: ('a -> bool) -> 'a list -> 'a list * 'a * 'a list) = + fun p -> function + | [] -> raise Not_found + | x::xs -> + if p x then + [], x, xs + else + let (l1, a, l2) = split_when p xs in + (x::l1, a, l2) +let _ = assert (split_when (fun x -> x =|= 3) + [1;2;3;4;1;2] =*= ([1;2],3,[4;1;2])) + + +(* not so easy to come up with ... used in aComment for split_paragraph *) +let rec split_gen_when_aux f acc xs = + match xs with + | [] -> + if null acc + then [] + else [List.rev acc] + | (x::xs) -> + (match f (x::xs) with + | None -> + split_gen_when_aux f (x::acc) xs + | Some (rest) -> + let before = List.rev acc in + if null before + then split_gen_when_aux f [] rest + else before::split_gen_when_aux f [] rest + ) +(* could avoid introduce extra aux function by using ?(acc = []) *) +let split_gen_when f xs = + split_gen_when_aux f [] xs + +let _ = assert (split_gen_when (function (42::xs) -> Some xs | _ -> None) + [1;2;42;4;5;6;42;7] =*= [[1;2];[4;5;6];[7]]) + + +(* generate exception (Failure "tl") if there is no element satisfying p *) +let rec (skip_until: ('a list -> bool) -> 'a list -> 'a list) = fun p xs -> + if p xs then xs else skip_until p (List.tl xs) +let _ = assert + (skip_until (function 1::2::xs -> true | _ -> false) + [1;3;4;1;2;4;5] =*= [1;2;4;5]) + +let rec skipfirst e = function + | [] -> [] + | e'::l when e =*= e' -> skipfirst e l + | l -> l + + +(* now in prelude: + * let rec enum x n = ... + *) + + +let index_list xs = + if null xs then [] (* enum 0 (-1) generate an exception *) + else zip xs (enum 0 ((List.length xs) -1)) + +(* if you want to use this to show the progress while processing huge list, + * consider instead Common_extra.progress + *) +let index_list_and_total xs = + let total = List.length xs in + if null xs then [] (* enum 0 (-1) generate an exception *) + else zip xs (enum 0 ((List.length xs) -1)) + +> List.map (fun (a,b) -> (a,b,total)) + +let index_list_0 xs = index_list xs + +let index_list_1 xs = + xs +> index_list +> List.map (fun (x,i) -> x, i+1) + +let avg_list xs = + let sum = sum_int xs in + (float_of_int sum) /. (float_of_int (List.length xs)) + +let snoc x xs = xs @ [x] +let cons x xs = x::xs + +let head_middle_tail xs = + match xs with + | x::y::xs -> + let head = x in + let reversed = List.rev (y::xs) in + let tail = List.hd reversed in + let middle = List.rev (List.tl reversed) in + head, middle, tail + | _ -> failwith "head_middle_tail, too small list" + +let _ = assert_equal (head_middle_tail [1;2;3]) (1, [2], 3) +let _ = assert_equal (head_middle_tail [1;3]) (1, [], 3) + +(* now in prelude + * let (++) = (@) + *) + +(* let (++) = (@), could do that, but if load many times the common, then pb *) +(* let (++) l1 l2 = List.fold_right (fun x acc -> x::acc) l1 l2 *) + +let remove x xs = + let newxs = List.filter (fun y -> y <> x) xs in + assert (List.length newxs =|= List.length xs - 1); + newxs + + +let rec remove_first e xs = + match xs with + | [] -> raise Not_found + | x::xs -> + if x =*= e + then xs + else x::(remove_first e xs) + +(* now in prelude +let exclude p xs = + List.filter (fun x -> not (p x)) xs +*) +(* now in prelude +*) + +let fold_k f lastk acc xs = + let rec fold_k_aux acc = function + | [] -> lastk acc + | x::xs -> + f acc x (fun acc -> fold_k_aux acc xs) + in + fold_k_aux acc xs + + +let rec list_init = function + | [] -> raise Not_found + | [x] -> [] + | x::y::xs -> x::(list_init (y::xs)) + +(* now in prelude: + * let rec list_last = function + * | [] -> raise Not_found + * | [x] -> x + * | x::y::xs -> list_last (y::xs) + *) + +(* pixel *) +(* now in prelude + * let last_n n l = List.rev (take n (List.rev l)) + * let last l = List.hd (last_n 1 l) + *) + +let rec join_gen a = function + | [] -> [] + | [x] -> [x] + | x::xs -> x::a::(join_gen a xs) + + +(* todo: foldl, foldr (a more consistent foldr) *) + +(* start pixel *) +let iter_index f l = + let rec iter_ n = function + | [] -> () + | e::l -> f e n ; iter_ (n+1) l + in iter_ 0 l + +let map_index f l = + let rec map_ n = function + | [] -> [] + | e::l -> f e n :: map_ (n+1) l + in map_ 0 l + + +(* pixel *) +let filter_index f l = + let rec filt i = function + | [] -> [] + | e::l -> if f i e then e :: filt (i+1) l else filt (i+1) l + in + filt 0 l + +(* pixel *) +let do_withenv doit f env l = + let r_env = ref env in + let l' = doit (fun e -> + let e', env' = f !r_env e in + r_env := env' ; e' + ) l in + l', !r_env + +(* now in prelude: + * let fold_left_with_index f acc = ... + *) + +let map_withenv f env e = do_withenv List.map f env e + +let rec collect_accu f accu = function + | [] -> accu + | e::l -> collect_accu f (List.rev_append (f e) accu) l + +let collect f l = List.rev (collect_accu f [] l) + +(* cf also List.partition *) + +let rec fpartition p l = + let rec part yes no = function + | [] -> (List.rev yes, List.rev no) + | x :: l -> + (match p x with + | None -> part yes (x :: no) l + | Some v -> part (v :: yes) no l) in + part [] [] l + +(* end pixel *) + +let rec removelast = function + | [] -> failwith "removelast" + | [_] -> [] + | e::l -> e :: removelast l + + +let empty list = null list + + +let rec inits = function + | [] -> [[]] + | e::l -> [] :: List.map (fun l -> e::l) (inits l) + +let rec tails = function + | [] -> [[]] + | (_::xs) as xxs -> xxs :: tails xs + + +let reverse = List.rev +let rev = List.rev + +let nth = List.nth +let fold_left = List.fold_left +let rev_map = List.rev_map + +(* pixel *) +let rec fold_right1 f = function + | [] -> failwith "fold_right1" + | [e] -> e + | e::l -> f e (fold_right1 f l) + +let maximum l = foldl1 max l +let minimum l = foldl1 min l + + +(* do a map tail recursive, and result is reversed, it is a tail recursive map => efficient *) +let map_eff_rev = fun f l -> + let rec map_eff_aux acc = + function + | [] -> acc + | x::xs -> map_eff_aux ((f x)::acc) xs + in + map_eff_aux [] l + +let acc_map f l = + let rec loop acc = function + [] -> List.rev acc + | x::xs -> loop ((f x)::acc) xs in + loop [] l + + +let rec (generate: int -> 'a -> 'a list) = fun i el -> + if i =|= 0 then [] + else el::(generate (i-1) el) + +let rec uniq = function + | [] -> [] + | e::l -> if List.mem e l then uniq l else e :: uniq l + +let has_no_duplicate xs = + List.length xs =|= List.length (uniq xs) +let is_set_as_list = has_no_duplicate + + +let rec get_duplicates xs = + match xs with + | [] -> [] + | x::xs -> + if List.mem x xs + then x::get_duplicates xs (* todo? could x from xs to avoid double dups?*) + else get_duplicates xs + +let rec all_assoc e = function + | [] -> [] + | (e',v) :: l when e=*=e' -> v :: all_assoc e l + | _ :: l -> all_assoc e l + +let prepare_want_all_assoc l = + List.map (fun n -> n, uniq (all_assoc n l)) (uniq (List.map fst l)) + +let rotate list = List.tl list @ [(List.hd list)] + +let or_list = List.fold_left (||) false +let and_list = List.fold_left (&&) true + +let rec (return_when: ('a -> 'b option) -> 'a list -> 'b) = fun p -> function + | [] -> raise Not_found + | x::xs -> (match p x with None -> return_when p xs | Some b -> b) + +let rec splitAt n xs = + if n =|= 0 then ([],xs) + else + (match xs with + | [] -> ([],[]) + | (x::xs) -> let (a,b) = splitAt (n-1) xs in (x::a, b) + ) + +let pack n xs = + let rec pack_aux l i = function + | [] -> failwith "not on a boundary" + | [x] -> if i =|= n then [l@[x]] else failwith "not on a boundary" + | x::xs -> + if i =|= n + then (l@[x])::(pack_aux [] 1 xs) + else pack_aux (l@[x]) (i+1) xs + in + pack_aux [] 1 xs + +let rec pack_safe n xs = + match xs with + | [] -> [] + | y::ys -> + let (a, b) = splitAt n xs in + a::pack_safe n b +let _ = assert + (pack_safe 2 [1;2;3;4;5] =*= [[1;2];[3;4];[5]]) + +let chunks n xs = + let size = List.length xs in + let chunksize = + if size mod n =|= 0 + then size / n + else 1 + (size / n) + in + let xxs = pack_safe chunksize xs in + if List.length xxs <> n + then failwith "chunks: impossible, wrong size"; + xxs + +let _ = assert + (chunks 2 [1;2;3;4] =*= [[1;2];[3;4]]) +let _ = assert + (chunks 2 [1;2;3;4;5] =*= [[1;2;3];[4;5]]) + + +let min_with f = function + | [] -> raise Not_found + | e :: l -> + let rec min_with_ min_val min_elt = function + | [] -> min_elt + | e::l -> + let val_ = f e in + if val_ < min_val + then min_with_ val_ e l + else min_with_ min_val min_elt l + in min_with_ (f e) e l + +let two_mins_with f = function + | e1 :: e2 :: l -> + let rec min_with_ min_val min_elt min_val2 min_elt2 = function + | [] -> min_elt, min_elt2 + | e::l -> + let val_ = f e in + if val_ < min_val2 + then + if val_ < min_val + then min_with_ val_ e min_val min_elt l + else min_with_ min_val min_elt val_ e l + else min_with_ min_val min_elt min_val2 min_elt2 l + in + let v1 = f e1 in + let v2 = f e2 in + if v1 < v2 then min_with_ v1 e1 v2 e2 l else min_with_ v2 e2 v1 e1 l + | _ -> raise Not_found + +let grep_with_previous f = function + | [] -> [] + | e::l -> + let rec grep_with_previous_ previous = function + | [] -> [] + | e::l -> if f previous e then e :: grep_with_previous_ e l else grep_with_previous_ previous l + in e :: grep_with_previous_ e l + +let iter_with_previous f = function + | [] -> () + | e::l -> + let rec iter_with_previous_ previous = function + | [] -> () + | e::l -> f previous e ; iter_with_previous_ e l + in iter_with_previous_ e l + +let iter_with_previous_opt f = function + | [] -> () + | e::l -> + f None e; + let rec iter_with_previous_ previous = function + | [] -> () + | e::l -> f (Some previous) e ; iter_with_previous_ e l + in iter_with_previous_ e l + + +let iter_with_before_after f xs = + let rec aux before_rev after = + match after with + | [] -> () + | x::xs -> + f before_rev x xs; + aux (x::before_rev) xs + in + aux [] xs + + + +(* kind of cartesian product of x*x *) +let rec (get_pair: ('a list) -> (('a * 'a) list)) = function + | [] -> [] + | x::xs -> (List.map (fun y -> (x,y)) xs) @ (get_pair xs) + + +(* retourne le rang dans une liste d'un element *) +let rang elem liste = + let rec rang_rec elem accu = function + | [] -> raise Not_found + | a::l -> if a =*= elem then accu + else rang_rec elem (accu+1) l in + rang_rec elem 1 liste + +(* retourne vrai si une liste contient des doubles *) +let rec doublon = function + | [] -> false + | a::l -> if List.mem a l then true + else doublon l + +let rec (insert_in: 'a -> 'a list -> 'a list list) = fun x -> function + | [] -> [[x]] + | y::ys -> (x::y::ys) :: (List.map (fun xs -> y::xs) (insert_in x ys)) +(* insert_in 3 [1;2] = [[3; 1; 2]; [1; 3; 2]; [1; 2; 3]] *) + +let rec (permutation: 'a list -> 'a list list) = function + | [] -> [] + | [x] -> [[x]] + | x::xs -> List.flatten (List.map (insert_in x) (permutation xs)) +(* permutation [1;2;3] = + * [[1; 2; 3]; [2; 1; 3]; [2; 3; 1]; [1; 3; 2]; [3; 1; 2]; [3; 2; 1]] + *) + + +let rec remove_elem_pos pos xs = + match (pos, xs) with + | _, [] -> failwith "remove_elem_pos" + | 0, x::xs -> xs + | n, x::xs -> x::(remove_elem_pos (n-1) xs) + +let rec insert_elem_pos (e, pos) xs = + match (pos, xs) with + | 0, xs -> e::xs + | n, x::xs -> x::(insert_elem_pos (e, (n-1)) xs) + | n, [] -> failwith "insert_elem_pos" + +let rec uncons_permut xs = + let indexed = index_list xs in + indexed +> List.map (fun (x, pos) -> (x, pos), remove_elem_pos pos xs) +let _ = + assert + (uncons_permut ['a';'b';'c'] =*= + [('a', 0), ['b';'c']; + ('b', 1), ['a';'c']; + ('c', 2), ['a';'b'] + ]) + +let rec uncons_permut_lazy xs = + let indexed = index_list xs in + indexed +> List.map (fun (x, pos) -> + (x, pos), + lazy (remove_elem_pos pos xs) + ) + + + + +(* pixel *) +let rec map_flatten f l = + let rec map_flatten_aux accu = function + | [] -> accu + | e :: l -> map_flatten_aux (List.rev (f e) @ accu) l + in List.rev (map_flatten_aux [] l) + +(* now in prelude: let rec repeat e n *) + +let rec map2 f = function + | [] -> [] + | x::xs -> let r = f x in r::map2 f xs + +let rec map3 f l = + let rec map3_aux acc = function + | [] -> acc + | x::xs -> map3_aux (f x::acc) xs in + map3_aux [] l + +(* +let tails2 xs = map rev (inits (rev xs)) +let res = tails2 [1;2;3;4] +let res = tails [1;2;3;4] +let id x = x +*) + +let pack_sorted same xs = + let rec pack_s_aux acc xs = + match (acc,xs) with + | ((cur,rest),[]) -> cur::rest + | ((cur,rest), y::ys) -> + if same (List.hd cur) y then pack_s_aux (y::cur, rest) ys + else pack_s_aux ([y], cur::rest) ys + in pack_s_aux ([List.hd xs],[]) (List.tl xs) +> List.rev +let test_pack = pack_sorted (=*=) [1;1;1;2;2;3;4] + + +let rec keep_best f = + let rec partition e = function + | [] -> e, [] + | e' :: l -> + match f(e,e') with + | None -> let (e'', l') = partition e l in e'', e' :: l' + | Some e'' -> partition e'' l + in function + | [] -> [] + | e::l -> + let (e', l') = partition e l in + e' :: keep_best f l' + +let rec sorted_keep_best f = function + | [] -> [] + | [a] -> [a] + | a :: b :: l -> + match f a b with + | None -> a :: sorted_keep_best f (b :: l) + | Some e -> sorted_keep_best f (e :: l) + + + +let (cartesian_product: 'a list -> 'b list -> ('a * 'b) list) = fun xs ys -> + xs +> List.map (fun x -> ys +> List.map (fun y -> (x,y))) + +> List.flatten + +let _ = assert_equal + (cartesian_product [1;2] ["3";"4";"5"]) + [1,"3";1,"4";1,"5"; 2,"3";2,"4";2,"5"] + +let sort_prof a b = + Common.profile_code "Common.sort_by_xxx" (fun () -> List.sort a b) + +type order = HighFirst | LowFirst +let compare_order order a b = + match order with + | HighFirst -> compare b a + | LowFirst -> compare a b + +let sort_by_val_highfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare v2 v1) xs +let sort_by_val_lowfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare v1 v2) xs + +let sort_by_key_highfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs +let sort_by_key_lowfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs + +let _ = assert (sort_by_key_lowfirst [4, (); 7,()] =*= [4,(); 7,()]) +let _ = assert (sort_by_key_highfirst [4,(); 7,()] =*= [7,(); 4,()]) + + +let sortgen_by_key_highfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare k2 k1) xs +let sortgen_by_key_lowfirst xs = + sort_prof (fun (k1,v1) (k2,v2) -> compare k1 k2) xs + + + + +(*----------------------------------*) + +(* sur surEnsemble [p1;p2] [[p1;p2;p3] [p1;p2] ....] -> [[p1;p2;p3] ... *) +(* mais pas p2;p3 *) +(* (aop) *) +let surEnsemble liste_el liste_liste_el = + List.filter + (function liste_elbis -> + List.for_all (function el -> List.mem el liste_elbis) liste_el + ) liste_liste_el;; + + + +(*----------------------------------*) +(* combinaison/product/.... (aop) *) +(* 123 -> 123 12 13 23 1 2 3 *) +let rec realCombinaison = function + | [] -> [] + | [a] -> [[a]] + | a::l -> + let res = realCombinaison l in + let res2 = List.map (function x -> a::x) res in + res2 @ res @ [[a]] + +(* genere toutes les combinaisons possible de paire *) +(* par exemple combinaison [1;2;4] -> [1, 2; 1, 4; 2, 4] *) +let rec combinaison = function + | [] -> [] + | [a] -> [] + | [a;b] -> [(a, b)] + | a::b::l -> (List.map (function elem -> (a, elem)) (b::l)) @ + (combinaison (b::l)) + +(*----------------------------------*) + +(* list of list(aop) *) +(* insere elem dans la liste de liste (si elem est deja present dans une de *) +(* ces listes, on ne fait rien *) +let rec insere elem = function + | [] -> [[elem]] + | a::l -> + if (List.mem elem a) then a::l + else a::(insere elem l) + +let rec insereListeContenant lis el = function + | [] -> [el::lis] + | a::l -> + if List.mem el a then + (List.append lis a)::l + else a::(insereListeContenant lis el l) + +(* fusionne les listes contenant et1 et et2 dans la liste de liste*) +let rec fusionneListeContenant (et1, et2) = function + | [] -> [[et1; et2]] + | a::l -> + (* si les deux sont deja dedans alors rien faire *) + if List.mem et1 a then + if List.mem et2 a then a::l + else + insereListeContenant a et2 l + else if List.mem et2 a then + insereListeContenant a et1 l + else a::(fusionneListeContenant (et1, et2) l) + +(*****************************************************************************) +(* Arrays *) +(*****************************************************************************) + +(* do bound checking ? *) +let array_find_index f a = + let rec array_find_index_ i = + if f i then i else array_find_index_ (i+1) + in + try array_find_index_ 0 with _ -> raise Not_found + +let array_find_index_via_elem f a = + let rec array_find_index_ i = + if f a.(i) then i else array_find_index_ (i+1) + in + try array_find_index_ 0 with _ -> raise Not_found + + + +type idx = Idx of int +let next_idx (Idx i) = (Idx (i+1)) +let int_of_idx (Idx i) = i + +let array_find_index_typed f a = + let rec array_find_index_ i = + if f i then i else array_find_index_ (next_idx i) + in + try array_find_index_ (Idx 0) with _ -> raise Not_found + + + +(*****************************************************************************) +(* Matrix *) +(*****************************************************************************) + +type 'a matrix = 'a array array + +let map_matrix f mat = + mat +> Array.map (fun arr -> arr +> Array.map f) + +let (make_matrix_init: + nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix) = + fun ~nrow ~ncolumn f -> + Array.init nrow (fun i -> + Array.init ncolumn (fun j -> + f i j + ) + ) + +let iter_matrix f m = + Array.iteri (fun i e -> + Array.iteri (fun j x -> + f i j x + ) e + ) m + +let nb_rows_matrix m = + Array.length m + +let nb_columns_matrix m = + assert(Array.length m > 0); + Array.length m.(0) + +(* check all nested arrays have the same size *) +let invariant_matrix m = + raise Common.Todo + +let (rows_of_matrix: 'a matrix -> 'a list list) = fun m -> + Array.to_list m +> List.map Array.to_list + +let (columns_of_matrix: 'a matrix -> 'a list list) = fun m -> + let nbcols = nb_columns_matrix m in + let nbrows = nb_rows_matrix m in + (enum 0 (nbcols -1)) +> List.map (fun j -> + (enum 0 (nbrows -1)) +> List.map (fun i -> + m.(i).(j) + )) + + +let all_elems_matrix_by_row m = + rows_of_matrix m +> List.flatten + + +let ex_matrix1 = + [| + [|0;1;2|]; + [|3;4;5|]; + [|6;7;8|]; + |] +let ex_rows1 = + [ + [0;1;2]; + [3;4;5]; + [6;7;8]; + ] +let ex_columns1 = + [ + [0;3;6]; + [1;4;7]; + [2;5;8]; + ] +let _ = assert (rows_of_matrix ex_matrix1 =*= ex_rows1) +let _ = assert (columns_of_matrix ex_matrix1 =*= ex_columns1) + + +(*****************************************************************************) +(* Fast array *) +(*****************************************************************************) +(* +module B_Array = Bigarray.Array2 +*) + +(* +open B_Array +open Bigarray +*) + + +(* for the string_of auto generation of camlp4 +val b_array_string_of_t : 'a -> 'b -> string +val bigarray_string_of_int16_unsigned_elt : 'a -> string +val bigarray_string_of_c_layout : 'a -> string +let b_array_string_of_t f a = "<>" +let bigarray_string_of_int16_unsigned_elt a = "<>" +let bigarray_string_of_c_layout a = "<>" + +*) + + +(*****************************************************************************) +(* Set. Have a look too at set*.mli *) +(*****************************************************************************) +type 'a set = 'a list + (* with sexp *) + +let (empty_set: 'a set) = [] +let (insert_set: 'a -> 'a set -> 'a set) = fun x xs -> + if List.mem x xs + then (* let _ = print_string "warning insert: already exist" in *) + xs + else x::xs + +let is_set xs = + has_no_duplicate xs + +let (single_set: 'a -> 'a set) = fun x -> insert_set x empty_set +let (set: 'a list -> 'a set) = fun xs -> + xs +> List.fold_left (flip insert_set) empty_set +> List.sort compare + +let (exists_set: ('a -> bool) -> 'a set -> bool) = List.exists +let (forall_set: ('a -> bool) -> 'a set -> bool) = List.for_all +let (filter_set: ('a -> bool) -> 'a set -> 'a set) = List.filter +let (fold_set: ('a -> 'b -> 'a) -> 'a -> 'b set -> 'a) = List.fold_left +let (map_set: ('a -> 'b) -> 'a set -> 'b set) = List.map +let (member_set: 'a -> 'a set -> bool) = List.mem + +let find_set = List.find +let sort_set = List.sort +let iter_set = List.iter + +let (top_set: 'a set -> 'a) = List.hd + +let (inter_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> + s1 +> fold_set (fun acc x -> if member_set x s2 then insert_set x acc else acc) empty_set +let (union_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> + s2 +> fold_set (fun acc x -> if member_set x s1 then acc else insert_set x acc) s1 +let (minus_set: 'a set -> 'a set -> 'a set) = fun s1 s2 -> + s1 +> filter_set (fun x -> not (member_set x s2)) + + +let union_all l = List.fold_left union_set [] l + +let big_union_set f xs = xs +> map_set f +> fold_set union_set empty_set + +let (card_set: 'a set -> int) = List.length + +let (include_set: 'a set -> 'a set -> bool) = fun s1 s2 -> + (s1 +> forall_set (fun p -> member_set p s2)) + +let equal_set s1 s2 = include_set s1 s2 && include_set s2 s1 + +let (include_set_strict: 'a set -> 'a set -> bool) = fun s1 s2 -> + (card_set s1 < card_set s2) && (include_set s1 s2) + +let ($*$) = inter_set +let ($+$) = union_set +let ($-$) = minus_set +let ($?$) a b = + Common.profile_code "$?$" (fun () -> member_set a b) +let ($<$) = include_set_strict +let ($<=$) = include_set +let ($=$) = equal_set + +(* as $+$ but do not check for memberness, allow to have set of func *) +let ($@$) = fun a b -> a @ b + +let rec nub = function + [] -> [] + | x::xs -> if List.mem x xs then nub xs else x::(nub xs) + +(*****************************************************************************) +(* Set as normal list *) +(*****************************************************************************) +(* +let (union: 'a list -> 'a list -> 'a list) = fun l1 l2 -> + List.fold_left (fun acc x -> if List.mem x l1 then acc else x::acc) l1 l2 + +let insert_normal x xs = union xs [x] + +(* retourne lis1 - lis2 *) +let minus l1 l2 = List.filter (fun x -> not (List.mem x l2)) l1 + +let inter l1 l2 = List.fold_left (fun acc x -> if List.mem x l2 then x::acc else acc) [] l1 + +let union_list = List.fold_left union [] + +let uniq lis = + List.fold_left (function acc -> function el -> union [el] acc) [] lis + +(* pixel *) +let rec non_uniq = function + | [] -> [] + | e::l -> if mem e l then e :: non_uniq l else non_uniq l + +let rec inclu lis1 lis2 = + List.for_all (function el -> List.mem el lis2) lis1 + +let equivalent lis1 lis2 = + (inclu lis1 lis2) && (inclu lis2 lis1) + +*) + + +(*****************************************************************************) +(* Set as sorted list *) +(*****************************************************************************) +(* liste trie, cos we need to do intersection, and insertion (it is a set + cos when introduce has, if we create a new has => must do a recurse_rep + and another categ can have to this has => must do an union + *) +(* +let rec insert x = function + | [] -> [x] + | y::ys -> + if x = y then y::ys + else (if x < y then x::y::ys else y::(insert x ys)) + +(* same, suppose sorted list *) +let rec intersect x y = + match(x,y) with + | [], y -> [] + | x, [] -> [] + | x::xs, y::ys -> + if x = y then x::(intersect xs ys) + else + (if x < y then intersect xs (y::ys) + else intersect (x::xs) ys + ) +(* intersect [1;3;7] [2;3;4;7;8];; *) +*) + +(*****************************************************************************) +(* Sets specialized *) +(*****************************************************************************) + +(* people often do that *) +module StringSetOrig = Set.Make(struct type t = string let compare = compare end) + +module StringSet = struct + include StringSetOrig + let of_list xs = + xs +> List.fold_left (fun acc e -> + StringSetOrig.add e acc + ) StringSetOrig.empty + let to_list t = + StringSetOrig.elements t +end + + +(*****************************************************************************) +(* Assoc *) +(*****************************************************************************) +type ('a,'b) assoc = ('a * 'b) list + (* with sexp *) + + +let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs -> + xs +> List.fold_left (fun acc (k, v) -> + (fun k' -> + if k =*= k' then v else acc k' + )) (fun k -> failwith "no key in this assoc") +(* simpler: +let (assoc_to_function: ('a, 'b) assoc -> ('a -> 'b)) = fun xs -> + fun k -> List.assoc k xs +*) + +let (empty_assoc: ('a, 'b) assoc) = [] +let fold_assoc = List.fold_left +let insert_assoc = fun x xs -> x::xs +let map_assoc = List.map +let filter_assoc = List.filter + +let assoc = List.assoc +let keys xs = List.map fst xs + +let lookup = assoc + +(* assert unique key ?*) +let del_assoc key xs = xs +> List.filter (fun (k,v) -> k <> key) +let replace_assoc (key, v) xs = insert_assoc (key, v) (del_assoc key xs) + +let apply_assoc key f xs = + let old = assoc key xs in + replace_assoc (key, f old) xs + +let big_union_assoc f xs = xs +> map_assoc f +> fold_assoc union_set empty_set + +(* todo: pb normally can suppr fun l -> .... l but if do that, then strange type _a + => assoc_map is strange too => equal dont work +*) +let (assoc_reverse: (('a * 'b) list) -> (('b * 'a) list)) = fun l -> + List.map (fun(x,y) -> (y,x)) l + +let (assoc_map: (('a * 'b) list) -> (('a * 'b) list) -> (('a * 'a) list)) = + fun l1 l2 -> + let (l1bis, l2bis) = (assoc_reverse l1, assoc_reverse l2) in + List.map (fun (x,y) -> (y, List.assoc x l2bis )) l1bis + +let rec (lookup_list: 'a -> ('a, 'b) assoc list -> 'b) = fun el -> function + | [] -> raise Not_found + | (xs::xxs) -> try List.assoc el xs with Not_found -> lookup_list el xxs + +let (lookup_list2: 'a -> ('a, 'b) assoc list -> ('b * int)) = fun el xxs -> + let rec lookup_l_aux i = function + | [] -> raise Not_found + | (xs::xxs) -> + try let res = List.assoc el xs in (res,i) + with Not_found -> lookup_l_aux (i+1) xxs + in lookup_l_aux 0 xxs + +let _ = assert + (lookup_list2 "c" [["a",1;"b",2];["a",1;"b",3];["a",1;"c",7]] =*= (7,2)) + + +let assoc_opt k l = + optionise (fun () -> List.assoc k l) + +let assoc_with_err_msg k l = + try List.assoc k l + with Not_found -> + pr2 (spf "pb assoc_with_err_msg: %s" (dump k)); + raise Not_found + +(*****************************************************************************) +(* Assoc int -> xxx with binary tree. Have a look too at Mapb.mli *) +(*****************************************************************************) + +(* ex: type robot_list = robot_info IntMap.t *) +module IntMap = Map.Make + (struct + type t = int + let compare = compare + end) +let intmap_to_list m = IntMap.fold (fun id v acc -> (id, v) :: acc) m [] +let intmap_string_of_t f a = "" + +module IntIntMap = Map.Make + (struct + type t = int * int + let compare = compare +end) + +let intintmap_to_list m = IntIntMap.fold (fun id v acc -> (id, v) :: acc) m [] +let intintmap_string_of_t f a = "" + + +(*****************************************************************************) +(* Hash *) +(*****************************************************************************) + +(* il parait que better when choose a prime *) +let hcreate () = Hashtbl.create 401 +let hadd (k,v) h = Hashtbl.add h k v +let hmem k h = Hashtbl.mem h k +let hfind k h = Hashtbl.find h k +let hreplace (k,v) h = Hashtbl.replace h k v +let hiter = Hashtbl.iter +let hfold = Hashtbl.fold +let hremove k h = Hashtbl.remove h k + + +let hash_to_list h = + Hashtbl.fold (fun k v acc -> (k,v)::acc) h [] + +> List.sort compare + +let hash_to_list_unsorted h = + Hashtbl.fold (fun k v acc -> (k,v)::acc) h [] + +let hash_of_list xs = + let h = Hashtbl.create 101 in + begin + (* replace or add? depends the semantic of hashtbl you want *) + xs +> List.iter (fun (k, v) -> Hashtbl.replace h k v); + h + end + +(* +let _ = + let h = Hashtbl.create 101 in + Hashtbl.add h "toto" 1; + Hashtbl.add h "toto" 1; + assert(hash_to_list h =*= ["toto",1; "toto",1]) +*) + + +let hfind_default key value_if_not_found h = + try Hashtbl.find h key + with Not_found -> + (Hashtbl.add h key (value_if_not_found ()); Hashtbl.find h key) + +(* not as easy as Perl $h->{key}++; but still possible *) +let hupdate_default key ~update:op ~default:value_if_not_found h = + let old = hfind_default key value_if_not_found h in + Hashtbl.replace h key (op old) + +let add1 old = old + 1 +let cst_zero () = 0 + +let hfind_option key h = + optionise (fun () -> Hashtbl.find h key) + + +(* see below: let hkeys h = ... *) + +let count_elements_sorted_highfirst xs = + let h = Hashtbl.create 101 in + xs +> List.iter (fun e -> + hupdate_default e (fun old -> old + 1) (fun () -> 0) h + ); + let xs = hash_to_list h in + (* not very efficient ... but simpler. use max_with_elem stuff ? *) + sort_by_val_highfirst xs + +let most_recurring_element xs = + let xs' = count_elements_sorted_highfirst xs in + match xs' with + | (e, count)::_ -> e + | [] -> failwith "most_recurring_element: empty list" + + + +(*****************************************************************************) +(* Hash sets *) +(*****************************************************************************) + +type 'a hashset = ('a, bool) Hashtbl.t + (* with sexp *) + + +let hash_hashset_add k e h = + match optionise (fun () -> Hashtbl.find h k) with + | Some hset -> Hashtbl.replace hset e true + | None -> + let hset = Hashtbl.create 11 in + begin + Hashtbl.add h k hset; + Hashtbl.replace hset e true; + end + +let hashset_to_set baseset h = + h +> hash_to_list +> List.map fst +> (fun xs -> baseset#fromlist xs) + +let hashset_to_list h = hash_to_list h +> List.map fst + +let hashset_of_list xs = + xs +> List.map (fun x -> x, true) +> hash_of_list + +let hashset_union h1 h2 = + h2 +> Hashtbl.iter (fun k _bool -> + Hashtbl.replace h1 k true + ) + +let hashset_inter h1 h2 = + h1 +> Hashtbl.iter (fun k _bool -> + if not (Hashtbl.mem h2 k) + then Hashtbl.remove h1 k + ) + + +let hkeys h = + let hkey = Hashtbl.create 101 in + h +> Hashtbl.iter (fun k v -> Hashtbl.replace hkey k true); + hashset_to_list hkey + +let hunion h1 h2 = + h2 +> Hashtbl.iter (fun k v -> + Hashtbl.add h1 k v + ) + + +let group_assoc_bykey_eff2 xs = + let h = Hashtbl.create 101 in + xs +> List.iter (fun (k, v) -> Hashtbl.add h k v); + let keys = hkeys h in + keys +> List.map (fun k -> k, Hashtbl.find_all h k) + +let group_assoc_bykey_eff xs = + Common.profile_code "Common.group_assoc_bykey_eff" (fun () -> + group_assoc_bykey_eff2 xs) + + +let test_group_assoc () = + let xs = enum 0 10000 +> List.map (fun i -> i_to_s i, i) in + let xs = ("0", 2)::xs in +(* let _ys = xs +> Common.groupBy (fun (a,resa) (b,resb) -> a =$= b) *) + let ys = xs +> group_assoc_bykey_eff + in + pr2_gen ys + + +let uniq_eff xs = + let h = Hashtbl.create 101 in + xs +> List.iter (fun k -> + Hashtbl.replace h k true + ); + hkeys h + +let big_union_eff xxs = + let h = Hashtbl.create 101 in + + xxs +> List.iter (fun xs -> + xs +> List.iter (fun k -> + Hashtbl.replace h k true + ); + ); + hkeys h + +let rec uniq_from_sorted acc = function + | [] -> acc + | [x] -> x :: acc + | x :: (y :: _ as rl) when x = y -> + uniq_from_sorted acc rl + | x :: rl -> uniq_from_sorted (x :: acc) rl + +let uniq_more_eff xs = + let l = List.sort (fun x y -> - compare x y) xs in + uniq_from_sorted [] l + + +let diff_set_eff xs1 xs2 = + let h1 = hashset_of_list xs1 in + let h2 = hashset_of_list xs2 in + + let hcommon = Hashtbl.create 101 in + let honly_in_h1 = Hashtbl.create 101 in + let honly_in_h2 = Hashtbl.create 101 in + + h1 +> Hashtbl.iter (fun k _ -> + if Hashtbl.mem h2 k + then Hashtbl.replace hcommon k true + else Hashtbl.add honly_in_h1 k true + ); + h2 +> Hashtbl.iter (fun k _ -> + if Hashtbl.mem h1 k + then Hashtbl.replace hcommon k true + else Hashtbl.add honly_in_h2 k true + ); + hashset_to_list hcommon, + hashset_to_list honly_in_h1, + hashset_to_list honly_in_h2 + +(*****************************************************************************) +(* Hash with default value *) +(*****************************************************************************) + +(* +type ('k,'v) hash_with_default = { + h: ('k, 'v) Hashtbl.t; + default_value: unit -> 'v; +} +*) +type ('a, 'b) hash_with_default = + < add : 'a -> 'b -> unit; + to_list : ('a * 'b) list; + to_h: ('a, 'b) Hashtbl.t; + update : 'a -> ('b -> 'b) -> unit; + assoc: 'a -> 'b; + > + +let hash_with_default fv = +object + val h = Hashtbl.create 101 + method to_list = hash_to_list h + method to_h = h + + method add k v = + Hashtbl.replace h k v + method assoc k = + Hashtbl.find h k + method update k f = + hupdate_default k ~update:f ~default:fv h +end + + + +(*****************************************************************************) +(* Stack *) +(*****************************************************************************) +type 'a stack = 'a list + (* with sexp *) + +let (empty_stack: 'a stack) = [] +(*let (push: 'a -> 'a stack -> 'a stack) = fun x xs -> x::xs *) +let (top: 'a stack -> 'a) = List.hd +let (pop: 'a stack -> 'a stack) = List.tl + +let top_option = function + | [] -> None + | x::xs -> Some x + + + + +(* now in prelude: + * let push2 v l = l := v :: !l + *) + +let pop2 l = + let v = List.hd !l in + begin + l := List.tl !l; + v + end + + +(*****************************************************************************) +(* Undoable Stack *) +(*****************************************************************************) + +(* Okasaki use such structure also for having efficient data structure + * supporting fast append. + *) + +type 'a undo_stack = 'a list * 'a list (* redo *) + +let (empty_undo_stack: 'a undo_stack) = + [], [] + +(* push erase the possible redo *) +let (push_undo: 'a -> 'a undo_stack -> 'a undo_stack) = fun x (undo,redo) -> + x::undo, [] + +let (top_undo: 'a undo_stack -> 'a) = fun (undo, redo) -> + List.hd undo + +let (pop_undo: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) -> + match undo with + | [] -> failwith "empty undo stack" + | x::xs -> + xs, x::redo + +let (undo_pop: 'a undo_stack -> 'a undo_stack) = fun (undo, redo) -> + match redo with + | [] -> failwith "empty redo, nothing to redo" + | x::xs -> + x::undo, xs + +let redo_undo x = undo_pop x + + +let top_undo_option = fun (undo, redo) -> + match undo with + | [] -> None + | x::xs -> Some x + +(*****************************************************************************) +(* Binary tree *) +(*****************************************************************************) + +(* type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree) *) + + +(*****************************************************************************) +(* N-ary tree *) +(*****************************************************************************) + +(* no empty tree, must have one root at list *) +type 'a tree2 = Tree of 'a * ('a tree2) list + +let rec (tree2_iter: ('a -> unit) -> 'a tree2 -> unit) = fun f tree -> + match tree with + | Tree (node, xs) -> + f node; + xs +> List.iter (tree2_iter f) + + +type ('a, 'b) tree = + | Node of 'a * ('a, 'b) tree list + | Leaf of 'b + (* with tarzan *) + +let rec map_tree ~fnode ~fleaf tree = + match tree with + | Leaf x -> Leaf (fleaf x) + | Node (x, xs) -> + Node (fnode x, xs +> List.map (map_tree ~fnode ~fleaf)) + + +(*****************************************************************************) +(* N-ary tree with updatable childrens *) +(*****************************************************************************) + +(* no empty tree, must have one root at list *) + +type 'a treeref = + | NodeRef of 'a * 'a treeref list ref + +let treeref_children_ref tree = + match tree with + | NodeRef (n, x) -> x + + + +let rec (treeref_node_iter: +(* (('a * ('a, 'b) treeref list ref) -> unit) -> + ('a, 'b) treeref -> unit +*) 'a) + = + fun f tree -> + match tree with +(* | LeafRef _ -> ()*) + | NodeRef (n, xs) -> + f (n, xs); + !xs +> List.iter (treeref_node_iter f) + + +let find_treeref f tree = + let res = ref [] in + + tree +> treeref_node_iter (fun (n, xs) -> + if f (n,xs) + then push (n, xs) res; + ); + match !res with + | [n,xs] -> NodeRef (n, xs) + | [] -> raise Not_found + | x::y::zs -> raise Common.Multi_found + +let rec (treeref_node_iter_with_parents: + (* (('a * ('a, 'b) treeref list ref) -> ('a list) -> unit) -> + ('a, 'b) treeref -> unit) + *) 'a) + = + fun f tree -> + let rec aux acc tree = + match tree with +(* | LeafRef _ -> ()*) + | NodeRef (n, xs) -> + f (n, xs) acc ; + !xs +> List.iter (aux (n::acc)) + in + aux [] tree + + +(* ---------------------------------------------------------------------- *) +(* Leaf can seem redundant, but sometimes want to directly see if + * a children is a leaf without looking if the list is empty. + *) +type ('a, 'b) treeref2 = + | NodeRef2 of 'a * ('a, 'b) treeref2 list ref + | LeafRef2 of 'b + + +let treeref2_children_ref tree = + match tree with + | LeafRef2 _ -> failwith "treeref_tail: leaf" + | NodeRef2 (n, x) -> x + + + +let rec (treeref_node_iter2: + (('a * ('a, 'b) treeref2 list ref) -> unit) -> + ('a, 'b) treeref2 -> unit) = + fun f tree -> + match tree with + | LeafRef2 _ -> () + | NodeRef2 (n, xs) -> + f (n, xs); + !xs +> List.iter (treeref_node_iter2 f) + + +let find_treeref2 f tree = + let res = ref [] in + + tree +> treeref_node_iter2 (fun (n, xs) -> + if f (n,xs) + then push (n, xs) res; + ); + match !res with + | [n,xs] -> NodeRef2 (n, xs) + | [] -> raise Not_found + | x::y::zs -> raise Common.Multi_found + + + + +let rec (treeref_node_iter_with_parents2: + (('a * ('a, 'b) treeref2 list ref) -> ('a list) -> unit) -> + ('a, 'b) treeref2 -> unit) = + fun f tree -> + let rec aux acc tree = + match tree with + | LeafRef2 _ -> () + | NodeRef2 (n, xs) -> + f (n, xs) acc ; + !xs +> List.iter (aux (n::acc)) + in + aux [] tree + + + + + + + + + + + + + +let find_treeref_with_parents_some f tree = + let res = ref [] in + + tree +> treeref_node_iter_with_parents (fun (n, xs) parents -> + match f (n,xs) parents with + | Some v -> push v res; + | None -> () + ); + match !res with + | [v] -> v + | [] -> raise Not_found + | x::y::zs -> raise Common.Multi_found + +let find_multi_treeref_with_parents_some f tree = + let res = ref [] in + + tree +> treeref_node_iter_with_parents (fun (n, xs) parents -> + match f (n,xs) parents with + | Some v -> push v res; + | None -> () + ); + match !res with + | [v] -> !res + | [] -> raise Not_found + | x::y::zs -> !res + + +(*****************************************************************************) +(* Graph. Have a look too at Ograph_*.mli *) +(*****************************************************************************) +(* + * Very simple implementation of a (directed) graph by list of pairs. + * Could also use a matrix, or adjacent list, or pointer(ref). + * todo: do some check (dont exist already, ...) + * todo: generalise to put in common (need 'edge (and 'c ?), + * and take in param a display func, cos caml sux, no overloading of show :( + *) + +type 'node graph = ('node set) * (('node * 'node) set) + +let (add_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) -> + (node::nodes, arcs) + +let (del_node: 'a -> 'a graph -> 'a graph) = fun node (nodes, arcs) -> + (nodes $-$ set [node], arcs) +(* could do more job: + let _ = assert (successors node (nodes, arcs) = empty) in + +> List.filter (fun (src, dst) -> dst != node)) +*) +let (add_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) -> + (nodes, set [arc] $+$ arcs) + +let (del_arc: ('a * 'a) -> 'a graph -> 'a graph) = fun arc (nodes, arcs) -> + (nodes, arcs +> List.filter (fun a -> not (arc =*= a))) + +let (successors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) -> + arcs +> List.filter (fun (src, dst) -> src =*= x) +> List.map snd + +let (predecessors: 'a -> 'a graph -> 'a set) = fun x (nodes, arcs) -> + arcs +> List.filter (fun (src, dst) -> dst =*= x) +> List.map fst + +let (nodes: 'a graph -> 'a set) = fun (nodes, arcs) -> nodes + +(* pre: no cycle *) +let rec (fold_upward: ('b -> 'a -> 'b) -> 'a set -> 'b -> 'a graph -> 'b) = + fun f xs acc graph -> + match xs with + | [] -> acc + | x::xs -> (f acc x) + +> (fun newacc -> fold_upward f (graph +> predecessors x) newacc graph) + +> (fun newacc -> fold_upward f xs newacc graph) + (* TODO avoid already visited *) + +let empty_graph = ([], []) + + + +(* +let (add_arcs_toward: int -> (int list) -> 'a graph -> 'a graph) = fun i xs -> + function + (nodes, arcs) -> (nodes, (List.map (fun j -> (j,i) ) xs)++arcs) +let (del_arcs_toward: int -> (int list) -> 'a graph -> 'a graph)= fun i xs g -> + List.fold_left (fun acc el -> del_arc (el, i) acc) g xs +let (add_arcs_from: int -> (int list) -> 'a graph -> 'a graph) = fun i xs -> + function + (nodes, arcs) -> (nodes, (List.map (fun j -> (i,j) ) xs)++arcs) + + +let (del_node: (int * 'node) -> 'node graph -> 'node graph) = fun node -> + function (nodes, arcs) -> + let newnodes = List.filter (fun a -> not (node = a)) nodes in + if newnodes = nodes then (raise Not_found) else (newnodes, arcs) +let (replace_node: int -> 'node -> 'node graph -> 'node graph) = fun i n -> + function (nodes, arcs) -> + let newnodes = List.filter (fun (j,_) -> not (i = j)) nodes in + ((i,n)::newnodes, arcs) +let (get_node: int -> 'node graph -> 'node) = fun i -> function + (nodes, arcs) -> List.assoc i nodes + +let (get_free: 'a graph -> int) = function + (nodes, arcs) -> (maximum (List.map fst nodes))+1 +(* require no cycle !! + TODO if cycle check that we have already visited a node *) +let rec (succ_all: int -> 'a graph -> (int list)) = fun i -> function + (nodes, arcs) as g -> + let direct = succ i g in + union direct (union_list (List.map (fun i -> succ_all i g) direct)) +let rec (pred_all: int -> 'a graph -> (int list)) = fun i -> function + (nodes, arcs) as g -> + let direct = pred i g in + union direct (union_list (List.map (fun i -> pred_all i g) direct)) +(* require that the nodes are different !! *) +let rec (equal: 'a graph -> 'a graph -> bool) = fun g1 g2 -> + let ((nodes1, arcs1),(nodes2, arcs2)) = (g1,g2) in + try + (* do 2 things, check same length and to assoc *) + let conv = assoc_map nodes1 nodes2 in + List.for_all (fun (i1,i2) -> + List.mem (List.assoc i1 conv, List.assoc i2 conv) arcs2) + arcs1 + && (List.length arcs1 = List.length arcs2) + (* could think that only forall is needed, but need check same lenth too*) + with _ -> false + +let (display: 'a graph -> ('a -> unit) -> unit) = fun g display_func -> + let rec aux depth i = + print_n depth " "; + print_int i; print_string "->"; display_func (get_node i g); + print_string "\n"; + List.iter (aux (depth+2)) (succ i g) + in aux 0 1 + +let (display_dot: 'a graph -> ('a -> string) -> unit)= fun (nodes,arcs) func -> + let file = open_out "test.dot" in + output_string file "digraph misc {\n" ; + List.iter (fun (n, node) -> + output_int file n; output_string file " [label=\""; + output_string file (func node); output_string file " \"];\n"; ) nodes; + List.iter (fun (i1,i2) -> output_int file i1 ; output_string file " -> " ; + output_int file i2 ; output_string file " ;\n"; ) arcs; + output_string file "}\n" ; + close_out file; + let status = Unix.system "viewdot test.dot" in + () +(* todo: faire = graphe (int can change !!! => cant make simply =) + reassign number first !! + *) + +(* todo: mettre diff(modulo = !!) en rouge *) +let (display_dot2: 'a graph -> 'a graph -> ('a -> string) -> unit) = + fun (nodes1, arcs1) (nodes2, arcs2) func -> + let file = open_out "test.dot" in + output_string file "digraph misc {\n" ; + output_string file "rotate = 90;\n"; + List.iter (fun (n, node) -> + output_string file "100"; output_int file n; + output_string file " [label=\""; + output_string file (func node); output_string file " \"];\n"; ) nodes1; + List.iter (fun (n, node) -> + output_string file "200"; output_int file n; + output_string file " [label=\""; + output_string file (func node); output_string file " \"];\n"; ) nodes2; + List.iter (fun (i1,i2) -> + output_string file "100"; output_int file i1 ; output_string file " -> " ; + output_string file "100"; output_int file i2 ; output_string file " ;\n"; + ) + arcs1; + List.iter (fun (i1,i2) -> + output_string file "200"; output_int file i1 ; output_string file " -> " ; + output_string file "200"; output_int file i2 ; output_string file " ;\n"; ) + arcs2; +(* output_string file "500 -> 1001; 500 -> 2001}\n" ; *) + output_string file "}\n" ; + close_out file; + let status = Unix.system "viewdot test.dot" in + () + + +*) +(*****************************************************************************) +(* Generic op *) +(*****************************************************************************) +(* overloading *) + +let map = List.map (* note: really really slow, use rev_map if possible *) +let filter = List.filter +let fold = List.fold_left +let member = List.mem +let iter = List.iter +let find = List.find +let exists = List.exists +let forall = List.for_all +let big_union f xs = xs +> map f +> fold union_set empty_set +(* let empty = [] *) +let empty_list = [] +let sort xs = List.sort Pervasives.compare xs +let length = List.length +(* in prelude now: let null xs = match xs with [] -> true | _ -> false *) +let head = List.hd +let tail = List.tl +let is_singleton = fun xs -> List.length xs =|= 1 +(*x: common.ml *) + +(*###########################################################################*) +(* Misc functions *) +(*###########################################################################*) + +(*****************************************************************************) +(* Geometry (raytracer) *) +(*****************************************************************************) + +type vector = (float * float * float) +type point = vector +type color = vector (* color(0-1) *) + +(* todo: factorise *) +let (dotproduct: vector * vector -> float) = + fun ((x1,y1,z1),(x2,y2,z2)) -> (x1*.x2 +. y1*.y2 +. z1*.z2) +let (vector_length: vector -> float) = + fun (x,y,z) -> sqrt (square x +. square y +. square z) +let (minus_point: point * point -> vector) = + fun ((x1,y1,z1),(x2,y2,z2)) -> ((x1 -. x2),(y1 -. y2),(z1 -. z2)) +let (distance: point * point -> float) = + fun (x1, x2) -> vector_length (minus_point (x2,x1)) +let (normalise: vector -> vector) = + fun (x,y,z) -> + let len = vector_length (x,y,z) in (x /. len, y /. len, z /. len) +let (mult_coeff: vector -> float -> vector) = + fun (x,y,z) c -> (x *. c, y *. c, z *. c) +let (add_vector: vector -> vector -> vector) = + fun v1 v2 -> let ((x1,y1,z1),(x2,y2,z2)) = (v1,v2) in + (x1+.x2, y1+.y2, z1+.z2) +let (mult_vector: vector -> vector -> vector) = + fun v1 v2 -> let ((x1,y1,z1),(x2,y2,z2)) = (v1,v2) in + (x1*.x2, y1*.y2, z1*.z2) +let sum_vector = List.fold_left add_vector (0.0,0.0,0.0) + +(*****************************************************************************) +(* Pics (raytracer) *) +(*****************************************************************************) + +type pixel = (int * int * int) (* RGB *) + +(* required pixel list in row major order, line after line *) +let (write_ppm: int -> int -> (pixel list) -> string -> unit) = fun + width height xs filename -> + let chan = open_out filename in + begin + output_string chan "P6\n"; + output_string chan ((string_of_int width) ^ "\n"); + output_string chan ((string_of_int height) ^ "\n"); + output_string chan "255\n"; + List.iter (fun (r,g,b) -> + List.iter (fun byt -> output_byte chan byt) [r;g;b] + ) xs; + close_out chan + end + +let test_ppm1 () = write_ppm 100 100 + ((generate (50*100) (1,45,100)) @ (generate (50*100) (1,1,100))) + "img.ppm" + +(*****************************************************************************) +(* Diff (lfs) *) +(*****************************************************************************) +type diff = Match | BnotinA | AnotinB + +let (diff: (int -> int -> diff -> unit)-> (string list * string list) -> unit)= + fun f (xs,ys) -> + let file1 = "/tmp/diff1-" ^ (string_of_int (Unix.getuid ())) in + let file2 = "/tmp/diff2-" ^ (string_of_int (Unix.getuid ())) in + let fileresult = "/tmp/diffresult-" ^ (string_of_int (Unix.getuid ())) in + write_file file1 (unwords xs); + write_file file2 (unwords ys); + command2 + ("diff --side-by-side -W 1 " ^ file1 ^ " " ^ file2 ^ " > " ^ fileresult); + let res = cat fileresult in + let a = ref 0 in + let b = ref 0 in + res +> List.iter (fun s -> + match s with + | ("" | " ") -> f !a !b Match; incr a; incr b; + | ">" -> f !a !b BnotinA; incr b; + | ("|" | "/" | "\\" ) -> + f !a !b BnotinA; f !a !b AnotinB; incr a; incr b; + | "<" -> f !a !b AnotinB; incr a; + | _ -> raise Common.Impossible + ) +(* +let _ = + diff + ["0";"a";"b";"c";"d"; "f";"g";"h";"j";"q"; "z"] + [ "a";"b";"c";"d";"e";"f";"g";"i";"j";"k";"r";"x";"y";"z"] + (fun x y -> pr "match") + (fun x y -> pr "a_not_in_b") + (fun x y -> pr "b_not_in_a") +*) + +let (diff2: (int -> int -> diff -> unit) -> (string * string) -> unit) = + fun f (xstr,ystr) -> + write_file "/tmp/diff1" xstr; + write_file "/tmp/diff2" ystr; + command2 + ("diff --side-by-side --left-column -W 1 " ^ + "/tmp/diff1 /tmp/diff2 > /tmp/diffresult"); + let res = cat "/tmp/diffresult" in + let a = ref 0 in + let b = ref 0 in + res +> List.iter (fun s -> + match s with + | "(" -> f !a !b Match; incr a; incr b; + | ">" -> f !a !b BnotinA; incr b; + | "|" -> f !a !b BnotinA; f !a !b AnotinB; incr a; incr b; + | "<" -> f !a !b AnotinB; incr a; + | _ -> raise Common.Impossible + ) + + +(*****************************************************************************) +(* Grep *) +(*****************************************************************************) + +(* src: coccinelle *) +let contain_any_token_with_egrep tokens file = + let tokens = tokens +> List.map (fun s -> + match () with + | _ when s =~ "^[A-Za-z_][A-Za-z_0-9]*$" -> + "\\b" ^ s ^ "\\b" + + | _ when s =~ "^[A-Za-z_]" -> + "\\b" ^ s + + | _ when s =~ ".*[A-Za-z_]$" -> + s ^ "\\b" + | _ -> s + + ) in + let cmd = spf "egrep -q '(%s)' %s" (join "|" tokens) file + in + (match Sys.command cmd with + | 0 (* success *) -> true + | _ (* failure *) -> false (* no match, so not worth trying *) + ) + +(*****************************************************************************) +(* Parsers (aop-colcombet) *) +(*****************************************************************************) + +let parserCommon lexbuf parserer lexer = + try + let result = parserer lexer lexbuf in + result + with Parsing.Parse_error -> + print_string "buf: "; print_string lexbuf.Lexing.lex_buffer; + print_string "\n"; + print_string "current: "; print_int lexbuf.Lexing.lex_curr_pos; + print_string "\n"; + raise Parsing.Parse_error + + +(* marche pas ca neuneu *) +(* +let getDoubleParser parserer lexer string = + let lexbuf1 = Lexing.from_string string in + let chan = open_in string in + let lexbuf2 = Lexing.from_channel chan in + (parserCommon lexbuf1 parserer lexer , parserCommon lexbuf2 parserer lexer ) +*) + +let getDoubleParser parserer lexer = + ( + (function string -> + let lexbuf1 = Lexing.from_string string in + parserCommon lexbuf1 parserer lexer + ), + (function string -> + let chan = open_in string in + let lexbuf2 = Lexing.from_channel chan in + parserCommon lexbuf2 parserer lexer + )) + + +(*****************************************************************************) +(* parser combinators *) +(*****************************************************************************) + +(* cf parser_combinators.ml + * + * Could also use ocaml stream. but not backtrack and forced to do LL, + * so combinators are better. + * + *) + + +(*****************************************************************************) +(* Parser related (cocci) *) +(*****************************************************************************) +(* now in h_program-lang/parse_info.ml *) + +(*x: common.ml *) +(*****************************************************************************) +(* Regression testing bis (cocci) *) +(*****************************************************************************) + +(* todo: keep also size of file, compute md5sum ? cos maybe the file + * has changed!. + * + * todo: could also compute the date, or some version info of the program, + * can record the first date when was found a OK, the last date where + * was ok, and then first date when found fail. So the + * Common.Ok would have more information that would be passed + * to the Common.Pb of date * date * date * string peut etre. + * + * todo? maybe use plain text file instead of marshalling. + *) + +type score_result = Ok | Pb of string + (* with sexp *) +type score = (string (* usually a filename *), score_result) Hashtbl.t + (* with sexp *) +type score_list = (string (* usually a filename *) * score_result) list + (* with sexp *) + +let empty_score () = (Hashtbl.create 101 : score) + + + +let regression_testing_vs newscore bestscore = + + let newbestscore = empty_score () in + + let allres = + (hash_to_list newscore +> List.map fst) + $+$ + (hash_to_list bestscore +> List.map fst) + in + begin + allres +> List.iter (fun res -> + match + optionise (fun () -> Hashtbl.find newscore res), + optionise (fun () -> Hashtbl.find bestscore res) + with + | None, None -> raise Common.Impossible + | Some x, None -> + Printf.printf "new test file appeared: %s\n" res; + Hashtbl.add newbestscore res x; + | None, Some x -> + Printf.printf "old test file disappeared: %s\n" res; + | Some newone, Some bestone -> + (match newone, bestone with + | Ok, Ok -> + Hashtbl.add newbestscore res Ok + | Pb x, Ok -> + Printf.printf + "PBBBBBBBB: a test file does not work anymore!!! : %s\n" res; + Printf.printf "Error : %s\n" x; + Hashtbl.add newbestscore res Ok + | Ok, Pb x -> + Printf.printf "Great: a test file now works: %s\n" res; + Hashtbl.add newbestscore res Ok + | Pb x, Pb y -> + Hashtbl.add newbestscore res (Pb x); + if not (x =$= y) + then begin + Printf.printf + "Semipb: still error but not same error : %s\n" res; + Printf.printf "%s\n" (chop ("Old error: " ^ y)); + Printf.printf "New error: %s\n" x; + end + ) + ); + flush stdout; flush stderr; + newbestscore + end + +let regression_testing newscore best_score_file = + + pr2 ("regression file: "^ best_score_file); + let (bestscore : score) = + if not (Sys.file_exists best_score_file) + then write_value (empty_score()) best_score_file; + get_value best_score_file + in + let newbestscore = regression_testing_vs newscore bestscore in + write_value newbestscore (best_score_file ^ ".old"); + write_value newbestscore best_score_file; + () + + + + +let string_of_score_result v = + match v with + | Ok -> "Ok" + | Pb s -> "Pb: " ^ s + +let total_scores score = + let total = hash_to_list score +> List.length in + let good = hash_to_list score +> List.filter + (fun (s, v) -> v =*= Ok) +> List.length in + good, total + + +let print_total_score score = + pr2 "--------------------------------"; + pr2 "total score"; + pr2 "--------------------------------"; + let (good, total) = total_scores score in + pr2 (Printf.sprintf "good = %d/%d" good total) + +let print_score score = + score +> hash_to_list +> List.iter (fun (k, v) -> + pr2 (Printf.sprintf "%s --> %s" k (string_of_score_result v)) + ); + print_total_score score; + () +(*x: common.ml *) +(*****************************************************************************) +(* Scope managment (cocci) *) +(*****************************************************************************) + +(* could also make a function Common.make_scope_functions that return + * the new_scope, del_scope, do_in_scope, add_env. Kind of functor :) + *) + +type ('a, 'b) scoped_env = ('a, 'b) assoc list + +(* +let rec lookup_env f env = + match env with + | [] -> raise Not_found + | []::zs -> lookup_env f zs + | (x::xs)::zs -> + match f x with + | None -> lookup_env f (xs::zs) + | Some y -> y + +let member_env_key k env = + try + let _ = lookup_env (fun (k',v) -> if k = k' then Some v else None) env in + true + with Not_found -> false + +*) + +let rec lookup_env k env = + match env with + | [] -> raise Not_found + | []::zs -> lookup_env k zs + | ((k',v)::xs)::zs -> + if k =*= k' + then v + else lookup_env k (xs::zs) + +let member_env_key k env = + match optionise (fun () -> lookup_env k env) with + | None -> false + | Some _ -> true + + +let new_scope scoped_env = scoped_env := []::!scoped_env +let del_scope scoped_env = scoped_env := List.tl !scoped_env + +let do_in_new_scope scoped_env f = + begin + new_scope scoped_env; + let res = f () in + del_scope scoped_env; + res + end + +let add_in_scope scoped_env def = + let (current, older) = uncons !scoped_env in + scoped_env := (def::current)::older + + + + + +(* note that ocaml hashtbl store also old value of a binding when add + * add a newbinding; that's why del_scope works + *) + +type ('a, 'b) scoped_h_env = { + scoped_h : ('a, 'b) Hashtbl.t; + scoped_list : ('a, 'b) assoc list; +} + +let empty_scoped_h_env () = { + scoped_h = Hashtbl.create 101; + scoped_list = [[]]; +} +let clone_scoped_h_env x = + { scoped_h = Hashtbl.copy x.scoped_h; + scoped_list = x.scoped_list; + } + +let rec lookup_h_env k env = + Hashtbl.find env.scoped_h k + +let member_h_env_key k env = + match optionise (fun () -> lookup_h_env k env) with + | None -> false + | Some _ -> true + + +let new_scope_h scoped_env = + scoped_env := {!scoped_env with scoped_list = []::!scoped_env.scoped_list} +let del_scope_h scoped_env = + begin + List.hd !scoped_env.scoped_list +> List.iter (fun (k, v) -> + Hashtbl.remove !scoped_env.scoped_h k + ); + scoped_env := {!scoped_env with scoped_list = + List.tl !scoped_env.scoped_list + } + end + +let do_in_new_scope_h scoped_env f = + begin + new_scope_h scoped_env; + let res = f () in + del_scope_h scoped_env; + res + end + +(* +let add_in_scope scoped_env def = + let (current, older) = uncons !scoped_env in + scoped_env := (def::current)::older +*) + +let add_in_scope_h x (k,v) = + begin + Hashtbl.add !x.scoped_h k v; + x := { !x with scoped_list = + ((k,v)::(List.hd !x.scoped_list))::(List.tl !x.scoped_list); + }; + end + +(*****************************************************************************) +(* Terminal *) +(*****************************************************************************) + +(* See console.ml *) + +(*****************************************************************************) +(* Gc optimisation (pfff) *) +(*****************************************************************************) + +(* opti: to avoid stressing the GC with a huge graph, we sometimes + * change a big AST into a string, which reduces the size of the graph + * to explore when garbage collecting. + *) +type 'a cached = 'a serialized_maybe ref + and 'a serialized_maybe = + | Serial of string + | Unfold of 'a + +let serial x = + ref (Serial (Marshal.to_string x [])) + +let unserial x = + match !x with + | Unfold c -> c + | Serial s -> + let res = Marshal.from_string s 0 in + (* x := Unfold res; *) + res + +(*****************************************************************************) +(* Random *) +(*****************************************************************************) + +let _init_random = Random.self_init () +(* +let random_insert i l = + let p = Random.int (length l +1) + in let rec insert i p l = + if (p = 0) then i::l else (hd l)::insert i (p-1) (tl l) + in insert i p l + +let rec randomize_list = function + [] -> [] + | a::l -> random_insert a (randomize_list l) +*) +let random_list xs = + List.nth xs (Random.int (length xs)) + +(* todo_opti: use fisher/yates algorithm. + * ref: http://en.wikipedia.org/wiki/Knuth_shuffle + * + * public static void shuffle (int[] array) + * { + * Random rng = new Random (); + * int n = array.length; + * while (--n > 0) + * { + * int k = rng.nextInt(n + 1); // 0 <= k <= n (!) + * int temp = array[n]; + * array[n] = array[k]; + * array[k] = temp; + * } + * } + + *) +let randomize_list xs = + let permut = permutation xs in + random_list permut + + + +let random_subset_of_list num xs = + let array = Array.of_list xs in + let len = Array.length array in + + let h = Hashtbl.create 101 in + let cnt = ref num in + while !cnt > 0 do + let x = Random.int len in + if not (Hashtbl.mem h (array.(x))) (* bugfix2: not just x :) *) + then begin + Hashtbl.add h (array.(x)) true; (* bugfix1: not just x :) *) + decr cnt; + end + done; + let objs = hash_to_list h +> List.map fst in + objs +(*x: common.ml *) +(*###########################################################################*) +(* Postlude *) +(*###########################################################################*) + + +(*****************************************************************************) +(* Flags and actions *) +(*****************************************************************************) + +(*s: common.ml cmdline *) + +(* I put it inside a func as it can help to give a chance to + * change the globals before getting the options as some + * options sometimes may want to show the default value. + *) +let cmdline_flags_devel () = + [ + "-debugger", Arg.Set Common.debugger, + " option to set if launched inside ocamldebug"; + "-profile", Arg.Unit (fun () -> Common.profile := Common.ProfAll), + " output profiling information"; + ] +let cmdline_flags_verbose () = + [ + "-verbose_level", Arg.Set_int verbose_level, + " guess what"; + "-disable_pr2_once", Arg.Set Common.disable_pr2_once, + " to print more messages"; + "-show_trace_profile", Arg.Set Common.show_trace_profile, + " show trace"; + ] + +let cmdline_flags_other () = + [ + "-nocheck_stack", Arg.Clear _check_stack, + " "; + "-batch_mode", Arg.Set _batch_mode, + " no interactivity"; + "-keep_tmp_files", Arg.Set Common.save_tmp_files, + " "; + ] + +(* potentially other common options but not yet integrated: + + "-timeout", Arg.Set_int timeout, + " interrupt LFS or buggy external plugins"; + + (* can't be factorized because of the $ cvs stuff, we want the date + * of the main.ml file, not common.ml + *) + "-version", Arg.Unit (fun () -> + pr2 "version: _dollar_Date: 2008/06/14 00:54:22 _dollar_"; + raise (Common.UnixExit 0) + ), + " guess what"; + + "-shorthelp", Arg.Unit (fun () -> + !short_usage_func(); + raise (Common.UnixExit 0) + ), + " see short list of options"; + "-longhelp", Arg.Unit (fun () -> + !long_usage_func(); + raise (Common.UnixExit 0) + ), + "-help", Arg.Unit (fun () -> + !long_usage_func(); + raise (Common.UnixExit 0) + ), + " "; + "--help", Arg.Unit (fun () -> + !long_usage_func(); + raise (Common.UnixExit 0) + ), + " "; + +*) + +let cmdline_actions () = + [ + "-test_check_stack", " ", + Common.mk_action_1_arg test_check_stack_size; + ] + +(*e: common.ml cmdline *) + +(*x: common.ml *) +(*****************************************************************************) +(* Postlude *) +(*****************************************************************************) +(* stuff put here cos of of forward definition limitation of ocaml *) + + +(* Infix trick, seen in jane street lib and harrop's code, and maybe in GMP *) +module Infix = struct + let (+>) = (+>) + let (|>) = (|>) + let (==~) = (==~) + let (=~) = (=~) +end + +(* based on code found in cameleon from maxence guesdon *) +let md5sum_of_string s = + let com = spf "echo %s | md5sum | cut -d\" \" -f 1" + (Filename.quote s) + in + match cmd_to_list com with + | [s] -> + (*pr2 s;*) + s + | _ -> failwith "md5sum_of_string wrong output" + +(* less: could also use the realpath C binding in Jane Street Core library. *) +let realpath path = + match cmd_to_list (spf "realpath %s" path) with + | [s] -> s + | xs -> + failwith (spf "problem with realpath on %s: %s " path (unlines xs)) + + +let with_pr2_to_string f = + let file = Common.new_temp_file "pr2" "out" in + redirect_stdout_stderr file f; + cat file + +(* julia: convert something printed using format to print into a string *) +let format_to_string f = + let (nm,o) = Filename.open_temp_file "format_to_s" ".out" in + (* to avoid interference with other code using Format.printf, e.g. + * Ounit.run_tt + *) + Format.print_flush(); + Format.set_formatter_out_channel o; + let _ = f () in + Format.print_newline(); + Format.print_flush(); + Format.set_formatter_out_channel stdout; + close_out o; + let i = open_in nm in + let lines = ref [] in + let rec loop _ = + let cur = input_line i in + lines := cur :: !lines; + loop() in + (try loop() with End_of_file -> ()); + close_in i; + command2 ("rm -f " ^ nm); + String.concat "\n" (List.rev !lines) + + + +(*---------------------------------------------------------------------------*) +(* Directories part 2 *) +(*---------------------------------------------------------------------------*) + +(* todo? vs common_prefix_of_files_or_dirs? *) +let find_common_root files = + let dirs_part = files +> List.map fst in + + let rec aux current_candidate xs = + try + let topsubdirs = xs +> List.map List.hd +> uniq_eff in + (match topsubdirs with + | [x] -> aux (x::current_candidate) (xs +> List.map List.tl) + | _ -> List.rev current_candidate + ) + with _ -> List.rev current_candidate + in + aux [] dirs_part + +(* +let _ = example + (find_common_root + [(["home";"pad"], "foo.php"); + (["home";"pad";"bar"], "bar.php"); + ] + =*= ["home";"pad"]) +*) + + +let dirs_and_base_of_file file = + let (dir, base) = db_of_filename file in + let dirs = split "/" dir in + let dirs = + match dirs with + | ["."] -> [] + | _ -> dirs + in + dirs, base + +(* +let _ = example + (dirs_and_base_of_file "/home/pad/foo.php" =*= (["home";"pad"], "foo.php")) +*) + + +let inits_of_absolute_dir dir = + assert (is_absolute dir); + assert (is_directory dir); + let dir = chop_dirsymbol dir in + + let dirs = split "/" dir in + let dirs = + match dirs with + | ["."] -> [] + | _ -> dirs + in + inits dirs +> List.map (fun xs -> + "/" ^ join "/" xs + ) + +let inits_of_relative_dir dir = + assert (is_relative dir); + let dir = chop_dirsymbol dir in + + let dirs = split "/" dir in + let dirs = + match dirs with + | ["."] -> [] + | _ -> dirs + in + inits dirs +> List.tl +> List.map (fun xs -> + join "/" xs + ) + +(* +let _ = example + (inits_of_absolute_dir "/usr/bin" =*= (["/"; "/usr"; "/usr/bin"])) + +let _ = example + (inits_of_relative_dir "usr/bin" =*= (["usr"; "usr/bin"])) +*) + + +(* main entry *) +let (tree_of_files: filename list -> (string, (string * filename)) tree) = + fun files -> + + let files_fullpath = files in + + (* extract dirs and file from file, e.g. ["home";"pad"], "__flib.php", path *) + let files = files +> List.map dirs_and_base_of_file in + + + (* find root, eg ["home";"pad"] *) + let root = find_common_root files in + + let files = zip files files_fullpath in + + (* remove the root part *) + let files = files +> List.map (fun ((dirs, base), path) -> + let n = List.length root in + let (root', rest) = + take n dirs, + drop n dirs + in + assert(root' =*= root); + (rest, base), path + ) + in + + (* now ready to build the tree recursively *) + let rec aux (xs: ((string list * string) * filename) list) = + let files_here, rest = + xs +> List.partition (fun ((dirs, base), _) -> null dirs) + in + let groups = + rest +> group_by_mapped_key (fun ((dirs, base),_) -> + (* would be a file if null dirs *) + assert(not (null dirs)); + List.hd dirs + ) in + + + let nodes = + groups +> List.map (fun (k, xs) -> + let xs' = xs +> List.map (fun ((dirs, base), path) -> + (List.tl dirs, base), path + ) + in + Node (k, aux xs') + ) + in + let leaves = files_here +> List.map (fun ((_dir, base), path) -> + Leaf (base, path) + ) in + nodes @ leaves + in + Node (join "/" root, + aux files) + + +(* finding the common root *) +let common_prefix_of_files_or_dirs2 xs = + let xs = xs +> List.map relative_to_absolute in + match xs with + | [] -> failwith "common_prefix_of_files_or_dirs: empty list" + | [x] -> x + | y::ys -> + (* todo: work when dirs ?*) + let xs = xs +> List.map dirs_and_base_of_file in + let dirs = find_common_root xs in + "/" ^ join "/" dirs + +let common_prefix_of_files_or_dirs xs = + Common.profile_code "Common.common_prefix_of" (fun () -> + common_prefix_of_files_or_dirs2 xs) + +(* +let _ = + example + (common_prefix_of_files_or_dirs ["/home/pad/pfff/visual"; + "/home/pad/pfff/commons";] + =*= "/home/pad/pfff" + ) +*) + +let unix_diff_strings s1 s2 = + let tmp1 = Common.new_temp_file "s1" "" in + write_file tmp1 s1; + let tmp2 = Common.new_temp_file "s2" "" in + write_file tmp2 s2; + unix_diff tmp1 tmp2 + +(*****************************************************************************) +(* Misc/test *) +(*****************************************************************************) + +let (generic_print: 'a -> string -> string) = fun v typ -> + write_value v "/tmp/generic_print"; + command2 + ("printf 'let (v:" ^ typ ^ ")= Common.get_value \"/tmp/generic_print\" " ^ + " in v;;' " ^ + " | calc.top > /tmp/result_generic_print"); + cat "/tmp/result_generic_print" + +> drop_while (fun e -> not (e =~ "^#.*")) +> tail + +> unlines + +> (fun s -> + if (s =~ ".*= \\(.+\\)") + then matched1 s + else "error in generic_print, not good format:" ^ s) + +(* let main () = pr (generic_print [1;2;3;4] "int list") *) + +class ['a] olist (ys: 'a list) = + object(o) + val xs = ys + method view = xs +(* method fold f a = List.fold_left f a xs *) + method fold : 'b. ('b -> 'a -> 'b) -> 'b -> 'b = + fun f accu -> List.fold_left f accu xs + end + + +(* let _ = write_value ((new setb[])#add 1) "/tmp/test" *) +let typing_sux_test () = + let x = Obj.magic [1;2;3] in + let f1 xs = List.iter print_int xs in + let f2 xs = List.iter print_string xs in + (f1 x; f2 x) + +(* let (test: 'a osetb -> 'a ocollection) = fun o -> (o :> 'a ocollection) *) +(* let _ = test (new osetb (Setb.empty)) *) + +(*e: common.ml *) diff --git a/commons/common2.mli b/commons/common2.mli new file mode 100644 index 0000000..49be7e6 --- /dev/null +++ b/commons/common2.mli @@ -0,0 +1,2049 @@ +(*s: common.mli *) +(*###########################################################################*) +(* Globals *) +(*###########################################################################*) +(*s: common.mli globals *) +(*****************************************************************************) +(* Flags *) +(*****************************************************************************) +(*s: common.mli globals flags *) +(* see the corresponding section for the use of those flags. See also + * the "Flags and actions" section at the end of this file. + *) + +val verbose_level : int ref + +(*e: common.mli globals flags *) + +(*****************************************************************************) +(* Flags and actions *) +(*****************************************************************************) +(* cf poslude *) + +(*****************************************************************************) +(* Misc/test *) +(*****************************************************************************) +(*s: common.mli misc/test *) +val generic_print : 'a -> string -> string + +class ['a] olist : + 'a list -> + object + val xs : 'a list + method fold : ('b -> 'a -> 'b) -> 'b -> 'b + method view : 'a list + end + +val typing_sux_test : unit -> unit +(*e: common.mli misc/test *) + +(*x: common.mli globals *) +(*****************************************************************************) +(* Module side effect *) +(*****************************************************************************) +(* + * I define a few unit tests via some let _ = example (... = ...). + * I also initialize the random seed, cf _init_random . + * I also set Gc.stack_size, cf _init_gc_stack . +*) +(*x: common.mli globals *) +(*****************************************************************************) +(* Semi globals *) +(*****************************************************************************) +(* cf the _xxx variables in this file *) +(*e: common.mli globals *) + +(*###########################################################################*) +(* Basic features *) +(*###########################################################################*) +(*s: common.mli basic features *) +(*****************************************************************************) +(* Pervasive types and operators *) +(*****************************************************************************) + +type filename = string +type dirname = string + +(* file or dir *) +type path = string + +(* Trick in case you dont want to do an 'open Common' while still wanting + * more pervasive types than the one in Pervasives. Just do the selective + * open Common.BasicType. + *) +module BasicType : sig + type filename = string +end + +(* Same spirit. Trick found in Jane Street core lib, but originated somewhere + * else I think: the ability to open nested modules. *) +module Infix : sig + val ( +> ) : 'a -> ('a -> 'b) -> 'b + val ( |> ) : 'a -> ('a -> 'b) -> 'b + val ( =~ ) : string -> string -> bool + val ( ==~ ) : string -> Str.regexp -> bool +end + + +(* + * Another related trick, found via Jon Harrop to have an extended standard + * lib is to do something like + * + * module List = struct + * include List + * val map2 : ... + * end + * + * And then can put this "module extension" somewhere to open it. + *) + + + +(* This module defines the Timeout and UnixExit exceptions. + * You have to make sure that those exn are not intercepted. So + * avoid exn handler such as try (...) with _ -> cos Timeout will not bubble up + * enough. In such case, add a case before such as + * with Timeout -> raise Timeout | _ -> ... + * The same is true for UnixExit (see below). + *) +(*x: common.mli basic features *) +(*****************************************************************************) +(* Debugging/logging *) +(*****************************************************************************) + +val _tab_level_print: int ref +val indent_do : (unit -> 'a) -> 'a +val reset_pr_indent : unit -> unit + +(* The following functions first indent _tab_level_print spaces. + * They also add the _prefix_pr, for instance used in MPI to show which + * worker is talking. + * update: for pr2, it can also print into a log file. + * + * The use of 2 in pr2 is because 2 is under UNIX the second descriptor + * which corresponds to stderr. + *) +val _prefix_pr : string ref + +val pr : string -> unit +val pr_no_nl : string -> unit +val pr_xxxxxxxxxxxxxxxxx : unit -> unit + +(* pr2 print on stderr, but can also in addition print into a file *) +val _chan_pr2: out_channel option ref +val pr2 : string -> unit +val pr2_no_nl : string -> unit +val pr2_xxxxxxxxxxxxxxxxx : unit -> unit + +(* use Dumper.dump *) +val pr2_gen: 'a -> unit +val dump: 'a -> string + +val pr2_once : string -> unit + +val mk_pr2_wrappers: bool ref -> (string -> unit) * (string -> unit) + + +val redirect_stdout_opt : filename option -> (unit -> 'a) -> 'a +val redirect_stdout_stderr : filename -> (unit -> unit) -> unit +val redirect_stdin : filename -> (unit -> unit) -> unit +val redirect_stdin_opt : filename option -> (unit -> unit) -> unit + +val with_pr2_to_string: (unit -> unit) -> string list + +(* +val fprintf : out_channel -> ('a, out_channel, unit) format -> 'a +val printf : ('a, out_channel, unit) format -> 'a +val eprintf : ('a, out_channel, unit) format -> 'a +val sprintf : ('a, unit, string) format -> 'a +*) + +(* alias *) +val spf : ('a, unit, string) format -> 'a + +(* default = stderr *) +val _chan : out_channel ref +(* generate & use a /tmp/debugml-xxx file *) +val start_log_file : unit -> unit + +(* see flag: val verbose_level : int ref *) +val log : string -> unit +val log2 : string -> unit +val log3 : string -> unit +val log4 : string -> unit + +val if_log : (unit -> unit) -> unit +val if_log2 : (unit -> unit) -> unit +val if_log3 : (unit -> unit) -> unit +val if_log4 : (unit -> unit) -> unit + +val pause : unit -> unit + +(* was used by fix_caml *) +val _trace_var : int ref +val add_var : unit -> unit +val dec_var : unit -> unit +val get_var : unit -> int + +val print_n : int -> string -> unit +val printerr_n : int -> string -> unit + +val _debug : bool ref +val debugon : unit -> unit +val debugoff : unit -> unit +val debug : (unit -> unit) -> unit + +(* see also logger.ml *) + +(* see flag: val debugger : bool ref *) +(*x: common.mli basic features *) +(*****************************************************************************) +(* Profiling (cpu/mem) *) +(*****************************************************************************) + +val get_mem : unit -> string +val memory_stat : unit -> string + +val timenow : unit -> string + +val _count1 : int ref +val _count2 : int ref +val _count3 : int ref +val _count4 : int ref +val _count5 : int ref + + +val count1 : unit -> unit +val count2 : unit -> unit +val count3 : unit -> unit +val count4 : unit -> unit +val count5 : unit -> unit +val profile_diagnostic_basic : unit -> string + +val time_func : (unit -> 'a) -> 'a + +(*x: common.mli basic features *) +(*****************************************************************************) +(* Test. But have a look at ounit.mli *) +(*****************************************************************************) + +(*old: val example : bool -> unit, PB with js_of_ocaml? *) +val example : bool -> unit +(* generate failwith when pb *) +val example2 : string -> bool -> unit +(* use Dumper to report when pb *) +val assert_equal : 'a -> 'a -> unit + +val _list_bool : (string * bool) list ref +val example3 : string -> bool -> unit +val test_all : unit -> unit + + +(* regression testing *) +type score_result = Ok | Pb of string +type score = (string (* usually a filename *), score_result) Hashtbl.t +type score_list = (string (* usually a filename *) * score_result) list +val empty_score : unit -> score +val regression_testing : + score -> filename (* old score file on disk (usually in /tmp) *) -> unit +val regression_testing_vs: score -> score -> score +val total_scores : score -> int (* good *) * int (* total *) +val print_score : score -> unit +val print_total_score: score -> unit + + +(* quickcheck spirit *) +type 'a gen = unit -> 'a + +(* quickcheck random generators *) +val ig : int gen +val lg : 'a gen -> 'a list gen +val pg : 'a gen -> 'b gen -> ('a * 'b) gen +val polyg : int gen +val ng : string gen + +val oneofl : 'a list -> 'a gen +val oneof : 'a gen list -> 'a gen +val always : 'a -> 'a gen +val frequency : (int * 'a gen) list -> 'a gen +val frequencyl : (int * 'a) list -> 'a gen + +val laws : string -> ('a -> bool) -> 'a gen -> 'a option + +(* example of use: + * let b = laws "unit" (fun x -> reverse [x] = [x]) ig + *) + +val statistic_number : 'a list -> (int * 'a) list +val statistic : 'a list -> (int * 'a) list + +val laws2 : + string -> ('a -> bool * 'b) -> 'a gen -> 'a option * (int * 'b) list +(*x: common.mli basic features *) +(*****************************************************************************) +(* Persistence *) +(*****************************************************************************) + +(* just wrappers around Marshal *) +val get_value : filename -> 'a +val read_value : filename -> 'a (* alias *) +val write_value : 'a -> filename -> unit +val write_back : ('a -> 'b) -> filename -> unit + +(* wrappers that also use profile_code *) +val marshal__to_string: 'a -> Marshal.extern_flags list -> string +val marshal__from_string: string -> int -> 'a +(*x: common.mli basic features *) +(*****************************************************************************) +(* Counter *) +(*****************************************************************************) +val _counter : int ref +val _counter2 : int ref +val _counter3 : int ref + +val counter : unit -> int +val counter2 : unit -> int +val counter3 : unit -> int + +type timestamp = int +(*x: common.mli basic features *) +(*****************************************************************************) +(* String_of and (pretty) printing *) +(*****************************************************************************) + +val string_of_string : (string -> string) -> string +val string_of_list : ('a -> string) -> 'a list -> string +val string_of_unit : unit -> string +val string_of_array : ('a -> string) -> 'a array -> string +val string_of_option : ('a -> string) -> 'a option -> string + +val print_bool : bool -> unit +val print_option : ('a -> 'b) -> 'a option -> unit +val print_list : ('a -> 'b) -> 'a list -> unit +val print_between : (unit -> unit) -> ('a -> unit) -> 'a list -> unit + +(* use Format internally *) +val pp_do_in_box : (unit -> unit) -> unit +val pp_f_in_box : (unit -> 'a) -> 'a +val pp_do_in_zero_box : (unit -> unit) -> unit +val pp : string -> unit + +(* convert something printed using Format to print into a string *) +val format_to_string : (unit -> unit) (* printer *) -> string + +(* works with _tab_level_print enabling to mix some calls to pp, pr2 + * and indent_do to sometimes use advanced indentation pretty printing + * (with the pp* functions) and sometimes explicit and simple indendation + * printing (with pr* and indent_do) *) +val adjust_pp_with_indent : (unit -> unit) -> unit +val adjust_pp_with_indent_and_header : string -> (unit -> unit) -> unit + + +val mk_str_func_of_assoc_conv: + ('a * string) list -> (string -> 'a) * ('a -> string) +(*x: common.mli basic features *) +(*****************************************************************************) +(* Macro *) +(*****************************************************************************) + +(* was working with my macro.ml4 *) +val macro_expand : string -> unit +(*x: common.mli basic features *) +(*****************************************************************************) +(* Composition/Control *) +(*****************************************************************************) + +val ( +> ) : 'a -> ('a -> 'b) -> 'b +val ( |> ) : 'a -> ('a -> 'b) -> 'b +val ( +!> ) : 'a ref -> ('a -> 'a) -> unit +val ( $ ) : ('a -> 'b) -> ('b -> 'c) -> 'a -> 'c + +val compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b +val flip : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c + +val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c +val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c + +val id : 'a -> 'a +val do_nothing : unit -> unit +val const: 'a -> 'b -> 'a + +val forever : (unit -> unit) -> unit + +val applyn : int -> ('a -> 'a) -> 'a -> 'a + +class ['a] shared_variable_hook : + 'a -> + object + val mutable data : 'a + val mutable registered : (unit -> unit) list + method get : 'a + method modify : ('a -> 'a) -> unit + method register : (unit -> unit) -> unit + method set : 'a -> unit + end + +val fixpoint : ('a -> 'a) -> 'a -> 'a +val fixpoint_for_object : ((< equal : 'a -> bool; .. > as 'a) -> 'a) -> 'a -> 'a + +val add_hook : ('a -> ('a -> 'b) -> 'b) ref -> ('a -> ('a -> 'b) -> 'b) -> unit +val add_hook_action : ('a -> unit) -> ('a -> unit) list ref -> unit +val run_hooks_action : 'a -> ('a -> unit) list ref -> unit + +type 'a mylazy = (unit -> 'a) + +(* emacs spirit *) +val save_excursion : 'a ref -> 'a -> (unit -> 'b) -> 'b +val save_excursion_and_disable : bool ref -> (unit -> 'b) -> 'b +val save_excursion_and_enable : bool ref -> (unit -> 'b) -> 'b + +val memoized : + ?use_cache:bool -> ('a, 'b) Hashtbl.t -> 'a -> (unit -> 'b) -> 'b + +val cache_in_ref : 'a option ref -> (unit -> 'a) -> 'a + + +(* take file from which computation is done, an extension, and the function + * and will compute the function only once and then save result in + * file ^ extension + *) +val cache_computation : + ?verbose:bool -> ?use_cache:bool -> filename -> string (* extension *) -> + (unit -> 'a) -> 'a + +(* a more robust version where the client describes the dependencies of the + * computation so it will relaunch the computation in 'f' if needed. + *) +val cache_computation_robust : + filename -> + string (* extension for marshalled object *) -> + (filename list * 'x) -> + string (* extension for marshalled dependencies *) -> + (unit -> 'a) -> + 'a + +val oncef : ('a -> unit) -> ('a -> unit) +val once: bool ref -> (unit -> unit) -> unit + +val before_leaving : ('a -> unit) -> 'a -> 'a + +(* cf also the timeout function below that are control related too *) +(*x: common.mli basic features *) +(*****************************************************************************) +(* Concurrency *) +(*****************************************************************************) + +(* how ensure really atomic file creation ? hehe :) *) +exception FileAlreadyLocked +val acquire_file_lock : filename -> unit +val release_file_lock : filename -> unit +(*x: common.mli basic features *) +(*****************************************************************************) +(* Error managment *) +(*****************************************************************************) +exception Here +exception ReturnExn + +exception WrongFormat of string + + +val internal_error : string -> 'a +val myassert : bool -> unit +val warning : string -> 'a -> 'a +val error_cant_have : 'a -> 'b + +val exn_to_s : exn -> string +(* alias *) +val string_of_exn : exn -> string + +val exn_to_s_with_backtrace : exn -> string + +type error = Error of string + +type evotype = unit +val evoval : evotype +(*x: common.mli basic features *) +(*****************************************************************************) +(* Environment *) +(*****************************************************************************) + +val _check_stack: bool ref + +val check_stack_size: int -> unit +val check_stack_nbfiles: int -> unit + +(* internally common.ml set Gc. parameters *) +val _init_gc_stack : unit +(*x: common.mli basic features *) + +(*x: common.mli basic features *) +(*****************************************************************************) +(* Equality *) +(*****************************************************************************) + +(* Using the generic (=) is tempting, but it backfires, so better avoid it *) + +(* To infer all the code that use an equal, and that should be + * transformed, is not that easy, because (=) is used by many + * functions, such as List.find, List.mem, and so on. The strategy to find + * them is to turn what you were previously using into a function, because + * (=) return an exception when applied to a function, then you simply + * use ocamldebug to detect where the code has to be transformed by + * finding where the exception was launched from. + *) + +val (=|=) : int -> int -> bool +val (=<=) : char -> char -> bool +val (=$=) : string -> string -> bool +val (=:=) : bool -> bool -> bool + +(* the evil generic (=). I define another symbol to more easily detect + * it, cos the '=' sign is syntaxically overloaded in caml. It is also + * used to define function. + *) +val (=*=): 'a -> 'a -> bool + +(* if want to restrict the use of '=', uncomment this: + * + * val (=): unit -> unit -> bool + * + * But it will not forbid you to use caml functions like List.find, List.mem + * which internaly use this convenient but evolution-unfriendly (=) +*) +(*e: common.mli basic features *) + +(*###########################################################################*) +(* Basic types *) +(*###########################################################################*) +(*s: common.mli for basic types *) +(*****************************************************************************) +(* Bool *) +(*****************************************************************************) + +val ( ||| ) : 'a -> 'a -> 'a +val ( ==> ) : bool -> bool -> bool +val xor : 'a -> 'a -> bool + +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Char *) +(*****************************************************************************) + +val string_of_char : char -> string +val string_of_chars : char list -> string + +val is_single : char -> bool +val is_symbol : char -> bool +val is_space : char -> bool +val is_upper : char -> bool +val is_lower : char -> bool +val is_alpha : char -> bool +val is_digit : char -> bool + +val cbetween : char -> char -> char -> bool +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Num *) +(*****************************************************************************) + +val ( /! ) : int -> int -> int + +val do_n : int -> (unit -> unit) -> unit +val foldn : ('a -> int -> 'a) -> 'a -> int -> 'a + +(* alias for flip do_n, ruby style *) +val times : (unit -> unit) -> int -> unit + +val pi : float +val pi2 : float +val pi4 : float + +val deg_to_rad : float -> float + +val clampf : float -> float + +val square : float -> float +val power : int -> int -> int + +val between : 'a -> 'a -> 'a -> bool +val between_strict : int -> int -> int -> bool +val bitrange : int -> int -> bool +val borne: min:'a -> max:'a -> 'a -> 'a + +val prime1 : int -> int option +val prime : int -> int option + +val sum : int list -> int +val product : int list -> int + +val decompose : int -> int list + +val mysquare : int -> int +val sqr : float -> float + +type compare = Equal | Inf | Sup +val ( <=> ) : 'a -> 'a -> compare +val ( <==> ) : 'a -> 'a -> int + +type uint = int + +val int_of_stringchar : string -> int +val int_of_base : string -> int -> int +val int_of_stringbits : string -> int +val int_of_octal : string -> int +val int_of_all : string -> int + +(* useful but sometimes when want grep for all places where do modif, + * easier to have just code using ':=' and '<-' to do some modifications. + * In the same way avoid using {contents = xxx} to build some ref. + *) +val ( += ) : int ref -> int -> unit +val ( -= ) : int ref -> int -> unit + +val pourcent: int -> int -> int +val pourcent_float: int -> int -> float +val pourcent_float_of_floats: float -> float -> float + +val pourcent_good_bad: int -> int -> int +val pourcent_good_bad_float: int -> int -> float + +type 'a max_with_elem = int ref * 'a ref +val update_max_with_elem: + 'a max_with_elem -> is_better:(int -> int ref -> bool) -> int * 'a -> unit + +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Numeric/overloading *) +(*****************************************************************************) + +type 'a numdict = + NumDict of + (('a -> 'a -> 'a) * ('a -> 'a -> 'a) * ('a -> 'a -> 'a) * ('a -> 'a)) +val add : 'a numdict -> 'a -> 'a -> 'a +val mul : 'a numdict -> 'a -> 'a -> 'a +val div : 'a numdict -> 'a -> 'a -> 'a +val neg : 'a numdict -> 'a -> 'a + +val numd_int : int numdict +val numd_float : float numdict + +val testd : 'a numdict -> 'a -> 'a + + +module ArithFloatInfix : sig + val (+) : float -> float -> float + val (-) : float -> float -> float + val (/) : float -> float -> float + val ( * ) : float -> float -> float + + + val (+..) : int -> int -> int + val (-..) : int -> int -> int + val (/..) : int -> int -> int + val ( *..) : int -> int -> int + + val (+=) : float ref -> float -> unit +end +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Random *) +(*****************************************************************************) + +val _init_random : unit +val random_list : 'a list -> 'a +val randomize_list : 'a list -> 'a list +val random_subset_of_list : int -> 'a list -> 'a list +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Tuples *) +(*****************************************************************************) + +type 'a pair = 'a * 'a +type 'a triple = 'a * 'a * 'a + +val fst3 : 'a * 'b * 'c -> 'a +val snd3 : 'a * 'b * 'c -> 'b +val thd3 : 'a * 'b * 'c -> 'c + +val sndthd : 'a * 'b * 'c -> 'b * 'c + +val map_fst : ('a -> 'b) -> 'a * 'c -> 'b * 'c +val map_snd : ('a -> 'b) -> 'c * 'a -> 'c * 'b + +val pair : ('a -> 'b) -> 'a * 'a -> 'b * 'b +val triple : ('a -> 'b) -> 'a * 'a * 'a -> 'b * 'b * 'b + +val double : 'a -> 'a * 'a +val swap : 'a * 'b -> 'b * 'a + +(* maybe a sign of bad programming if use those functions :) *) +val tuple_of_list1 : 'a list -> 'a +val tuple_of_list2 : 'a list -> 'a * 'a +val tuple_of_list3 : 'a list -> 'a * 'a * 'a +val tuple_of_list4 : 'a list -> 'a * 'a * 'a * 'a +val tuple_of_list5 : 'a list -> 'a * 'a * 'a * 'a * 'a +val tuple_of_list6 : 'a list -> 'a * 'a * 'a * 'a * 'a * 'a +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Maybe *) +(*****************************************************************************) + +type ('a, 'b) either = Left of 'a | Right of 'b +type ('a, 'b, 'c) either3 = Left3 of 'a | Middle3 of 'b | Right3 of 'c + +val just : 'a option -> 'a +val some : 'a option -> 'a (* alias *) + +val fmap : ('a -> 'b) -> 'a option -> 'b option +val map_option : ('a -> 'b) -> 'a option -> 'b option (* alias *) + +val do_option : ('a -> unit) -> 'a option -> unit +val opt: ('a -> unit) -> 'a option -> unit + +val optionise : (unit -> 'a) -> 'a option + +val some_or : 'a option -> 'a -> 'a +val option_to_list: 'a option -> 'a list + +val partition_either : + ('a -> ('b, 'c) either) -> 'a list -> 'b list * 'c list +val partition_either3 : + ('a -> ('b, 'c, 'd) either3) -> 'a list -> 'b list * 'c list * 'd list + +val filter_some : 'a option list -> 'a list +val map_filter : ('a -> 'b option) -> 'a list -> 'b list +val find_some : ('a -> 'b option) -> 'a list -> 'b +val find_some_opt : ('a -> 'b option) -> 'a list -> 'b option + +val list_to_single_or_exn: 'a list -> 'a + +val while_some: gen:(unit-> 'a option) -> f:('a -> 'b) -> unit -> 'b list + +val (||=): 'a option ref -> (unit -> 'a) -> unit + +val (>>=): 'a option -> ('a -> 'b option) -> 'b option +val (|?):'a option -> 'a Lazy.t -> 'a + +(*x: common.mli for basic types *) +(*****************************************************************************) +(* TriBool *) +(*****************************************************************************) +type bool3 = True3 | False3 | TrueFalsePb3 of string +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Strings *) +(*****************************************************************************) + +val slength : string -> int (* alias *) +val concat : string -> string list -> string (* alias *) + +val i_to_s : int -> string +val s_to_i : string -> int + +(* strings take space in memory. Better when can share the space used by + * similar strings. + *) +val _shareds : (string, string) Hashtbl.t +val shared_string : string -> string + +val chop : string -> string +val chop_dirsymbol : string -> string + +val ( ) : string -> int * int -> string +val ( ) : string -> int -> char + +val take_string: int -> string -> string +val take_string_safe: int -> string -> string + +val split_on_char : char -> string -> string list + +val lowercase : string -> string + +val quote : string -> string +val unquote : string -> string + +val null_string : string -> bool +val is_blank_string : string -> bool +val is_string_prefix : string -> string -> bool + + +val plural : int -> string -> string + +val showCodeHex : int list -> unit + +val size_mo_ko : int -> string +val size_ko : int -> string + +val edit_distance: string -> string -> int + +val md5sum_of_string : string -> string + +val wrap: ?width:int -> string -> string + +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Regexp *) +(*****************************************************************************) + +val regexp_alpha : Str.regexp +val regexp_word : Str.regexp + +val _memo_compiled_regexp : (string, Str.regexp) Hashtbl.t +val ( =~ ) : string -> string -> bool +val ( ==~ ) : string -> Str.regexp -> bool + + + +val regexp_match : string -> string -> string + +val matched : int -> string -> string + +(* not yet politypic functions in ocaml *) +val matched1 : string -> string +val matched2 : string -> string * string +val matched3 : string -> string * string * string +val matched4 : string -> string * string * string * string +val matched5 : string -> string * string * string * string * string +val matched6 : string -> string * string * string * string * string * string +val matched7 : string -> string * string * string * string * string * string * string + +val string_match_substring : Str.regexp -> string -> bool + +val split : string (* sep regexp *) -> string -> string list +val join : string (* sep *) -> string list -> string + +val split_list_regexp : string -> string list -> (string * string list) list +val split_list_regexp_noheading : string + +val all_match : string (* regexp *) -> string -> string list +val global_replace_regexp : + string (* regexp *) -> (string -> string) -> string -> string + +val regular_words: string -> string list +val contain_regular_word: string -> bool + +type regexp = + | Contain of string + | Start of string + | End of string + | Exact of string + +val regexp_string_of_regexp: regexp -> string +val str_regexp_of_regexp: regexp -> Str.regexp + +val compile_regexp_union: regexp list -> Str.regexp + +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Filenames *) +(*****************************************************************************) + +(* now at beginning of this file: type filename = string *) +val dirname : string -> string +val basename : string -> string + +val filesuffix : filename -> string +val fileprefix : filename -> string + +val adjust_ext_if_needed : filename -> string -> filename + +(* db for dir, base *) +val db_of_filename : filename -> (string * filename) +val filename_of_db : (string * filename) -> filename + +(* dbe for dir, base, ext *) +val dbe_of_filename : filename -> string * string * string +val dbe_of_filename_nodot : filename -> string * string * string +(* Left (d,b,e) | Right (d,b) if file has no extension *) +val dbe_of_filename_safe : + filename -> (string * string * string, string * string) either +val dbe_of_filename_noext_ok : filename -> string * string * string + +val filename_of_dbe : string * string * string -> filename + +(* ex: replace_ext "toto.c" "c" "var" *) +val replace_ext: filename -> string -> string -> filename + +(* remove the ., .. *) +val normalize_path : filename -> filename + +val relative_to_absolute : filename -> filename + +val is_relative: filename -> bool +val is_absolute: filename -> bool + +val filename_without_leading_path : string -> filename -> filename + +(* see below +val tree2_of_files: filename list -> (dirname, (string * filename)) tree2 +*) + +val realpath: filename -> filename + +val inits_of_absolute_dir: dirname -> dirname list +val inits_of_relative_dir: dirname -> dirname list + +(* basic file position *) +type filepos = { + l: int; + c: int; +} + +(*x: common.mli for basic types *) +(*****************************************************************************) +(* i18n *) +(*****************************************************************************) +type langage = + | English + | Francais + | Deutsch +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Dates *) +(*****************************************************************************) + +(* can also use ocamlcalendar, but heavier, use many modules ... *) + +type month = + | Jan | Feb | Mar | Apr | May | Jun + | Jul | Aug | Sep | Oct | Nov | Dec +type year = Year of int +type day = Day of int + +type date_dmy = DMY of day * month * year + +type hour = Hour of int +type minute = Min of int +type second = Sec of int + +type time_hms = HMS of hour * minute * second + +type full_date = date_dmy * time_hms + + +(* intervalle *) +type days = Days of int + +type time_dmy = TimeDMY of day * month * year + + +(* from Unix *) +type float_time = float + + +val mk_date_dmy : int -> int -> int -> date_dmy + + +val check_date_dmy : date_dmy -> unit +val check_time_dmy : time_dmy -> unit +val check_time_hms : time_hms -> unit + +val int_to_month : int -> string +val int_of_month : month -> int +val month_of_string : string -> month +val month_of_string_long : string -> month +val string_of_month : month -> string + +val string_of_date_dmy : date_dmy -> string +val date_dmy_of_string : string -> date_dmy + +val string_of_unix_time : ?langage:langage -> Unix.tm -> string +val short_string_of_unix_time : ?langage:langage -> Unix.tm -> string +val string_of_floattime: ?langage:langage -> float_time -> string +val short_string_of_floattime: ?langage:langage -> float_time -> string + +val floattime_of_string: string -> float_time + +val dmy_to_unixtime: date_dmy -> float_time * Unix.tm +val unixtime_to_dmy: Unix.tm -> date_dmy +val unixtime_to_floattime: Unix.tm -> float_time +val floattime_to_unixtime: float_time -> Unix.tm +val floattime_to_dmy: float_time -> date_dmy + +val sec_to_days : int -> string +val sec_to_hours : int -> string + +val today : unit -> float_time +val yesterday : unit -> float_time +val tomorrow : unit -> float_time + +val lastweek : unit -> float_time +val lastmonth : unit -> float_time + +val week_before: float_time -> float_time +val month_before: float_time -> float_time +val week_after: float_time -> float_time + +val days_in_week_of_day : float_time -> float_time list + +val first_day_in_week_of_day : float_time -> float_time +val last_day_in_week_of_day : float_time -> float_time + +val day_secs: float_time + +val rough_days_since_jesus : date_dmy -> days +(* to get a positive numbers the second date must be more recent than + * the first. + *) +val rough_days_between_dates : date_dmy -> date_dmy -> days + +val string_of_unix_time_lfs : Unix.tm -> string + +val is_more_recent : date_dmy -> date_dmy -> bool +val max_dmy : date_dmy -> date_dmy -> date_dmy +val min_dmy : date_dmy -> date_dmy -> date_dmy +val maximum_dmy : date_dmy list -> date_dmy +val minimum_dmy : date_dmy list -> date_dmy + +(* useful to put in logs as prefix *) +val timestamp: unit -> string + +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Lines/Words/Strings *) +(*****************************************************************************) + +val list_of_string : string -> char list + +val lines : string -> string list +val unlines : string list -> string + +val words : string -> string list +val unwords : string list -> string + +val split_space : string -> string list + +val lines_with_nl : string -> string list + +val nblines : filename -> int +val nblines_eff : filename -> int +(* better when really large file, but fork is slow so don't call it often *) +val nblines_with_wc : filename -> int +val unix_diff: filename -> filename -> string list +val unix_diff_strings: string -> string -> string list + +val words_of_string_with_newlines: string -> string list + +(* e.g. on "ab\n\nc" it will return [Left "ab"; Right (); Right (); Left "c"] *) +val lines_with_nl_either: string -> (string, unit) either list + +val n_space: int -> string +(* reindent a string *) +val indent_string: int -> string -> string + +(*x: common.mli for basic types *) +(*****************************************************************************) +(* Process/Files *) +(*****************************************************************************) +val cat : filename -> string list +val cat_orig : filename -> string list +val cat_array: filename -> string array +val cat_excerpts: filename -> int list -> string list + +val uncat: string list -> filename -> unit + +val interpolate : string -> string list + +val echo : string -> string + +val usleep : int -> unit + +exception CmdError of Unix.process_status * string + +val cmd_to_list_and_status : ?verbose:bool -> string -> string list * Unix.process_status + +(* will raise CmdError *) +val process_output_to_list : ?verbose:bool -> string -> string list +val cmd_to_list : ?verbose:bool -> string -> string list (* alias *) + +val command2 : string -> unit +val _batch_mode: bool ref +val command_safe: ?verbose:bool -> + filename (* executable *) -> string list (* args *) -> int + +val y_or_no: string -> bool + +val command2_y_or_no : string -> bool +val command2_y_or_no_exit_if_no : string -> unit + +val do_in_fork : (unit -> unit) -> int + +val mkdir: ?mode:Unix.file_perm -> string -> unit + +val read_file : filename -> string +val write_file : file:filename -> string -> unit + + +val nblines_file : filename -> int + +val filesize : filename -> int +val filemtime : filename -> float +val lfile_exists : filename -> bool + +val is_directory : path -> bool +val is_file : path -> bool +val is_symlink: filename -> bool +val is_executable : filename -> bool + +val unix_lstat_eff: filename -> Unix.stats +val unix_stat_eff: filename -> Unix.stats + +(* require to pass absolute paths, and use internally a memoized lstat *) +val filesize_eff : filename -> int +val filemtime_eff : filename -> float +val lfile_exists_eff : filename -> bool +val is_directory_eff : path -> bool +val is_file_eff : path -> bool +val is_executable_eff : filename -> bool + +val capsule_unix : ('a -> unit) -> 'a -> unit + +val readdir_to_kind_list : string -> Unix.file_kind -> string list +val readdir_to_dir_list : string -> dirname list +val readdir_to_file_list : string -> filename list +val readdir_to_link_list : string -> string list +val readdir_to_dir_size_list : string -> (string * int) list + +val unixname: unit -> string + + +val glob : string -> filename list +val files_of_dir_or_files : + string (* ext *) -> string list -> filename list +val files_of_dir_or_files_no_vcs : + string (* ext *) -> string list -> filename list +(* use a post filter =~ for the ext filtering *) +val files_of_dir_or_files_no_vcs_post_filter : + string (* regexp *) -> string list -> filename list +val files_of_dir_or_files_no_vcs_nofilter: + string list -> filename list + +val dirs_of_dir: dirname -> dirname list + +val common_prefix_of_files_or_dirs: path list -> dirname + +val sanity_check_files_and_adjust : + string (* ext *) -> string list -> filename list + + +type rwx = [ `R | `W | `X ] list +val file_perm_of : u:rwx -> g:rwx -> o:rwx -> Unix.file_perm + +val has_env : string -> bool + +(* scheme spirit. do a finalize so no leak. *) +val with_open_outfile_append : + filename -> ((string -> unit) * out_channel -> 'a) -> 'a + +val with_open_stringbuf : + (((string -> unit) * Buffer.t) -> unit) -> string + +exception Timeout + +(* subtil: have to make sure that Timeout is not intercepted before here. So + * avoid exn handler such as try (...) with _ -> cos Timeout will not bubble up + * enough. In such case, add a case before such as + * with Timeout -> raise Timeout | _ -> ... + * + * The same is true for UnixExit (see below). + *) +val timeout_function : + ?verbose:bool -> + int -> (unit -> 'a) -> 'a + +val timeout_function_opt : int option -> (unit -> 'a) -> 'a + + +val with_tmp_file: str:string -> ext:string -> (filename -> 'a) -> 'a +val with_tmp_dir: (dirname -> 'a) -> 'a + +(* If the user use some exit 0 in his code, then no one can intercept this + * exit and do something before exiting. There is exn handler for exit 0 + * so better never use exit 0 but instead use an exception and just at + * the very toplevel transform this exn in a unix exit code. + * + * subtil: same problem than with Timeout. Do not intercept such exception + * with some blind try (...) with _ -> ... + *) +exception UnixExit of int +val exn_to_real_unixexit : (unit -> 'a) -> 'a +(*e: common.mli for basic types *) + +(*###########################################################################*) +(* Collection-like types *) +(*###########################################################################*) +(*s: common.mli for collection types *) +(*****************************************************************************) +(* List *) +(*****************************************************************************) + + +(* tail recursive efficient map (but that also reverse the element!) *) +val map_eff_rev : ('a -> 'b) -> 'a list -> 'b list +(* tail recursive efficient map, use accumulator *) +val acc_map : ('a -> 'b) -> 'a list -> 'b list + + +val zip : 'a list -> 'b list -> ('a * 'b) list +val zip_safe : 'a list -> 'b list -> ('a * 'b) list +val unzip : ('a * 'b) list -> 'a list * 'b list + +val take : int -> 'a list -> 'a list +val take_safe : int -> 'a list -> 'a list +val take_until : ('a -> bool) -> 'a list -> 'a list +val take_while : ('a -> bool) -> 'a list -> 'a list + +val drop : int -> 'a list -> 'a list +val drop_while : ('a -> bool) -> 'a list -> 'a list +val drop_until : ('a -> bool) -> 'a list -> 'a list + +val span : ('a -> bool) -> 'a list -> 'a list * 'a list +val span_tail_call : ('a -> bool) -> 'a list -> 'a list * 'a list + +val skip_until : ('a list -> bool) -> 'a list -> 'a list +val skipfirst : (* Eq a *) 'a -> 'a list -> 'a list + +(* cf also List.partition *) +val fpartition : ('a -> 'b option) -> 'a list -> 'b list * 'a list + +val groupBy : ('a -> 'a -> bool) -> 'a list -> 'a list list +val exclude_but_keep_attached: ('a -> bool) -> 'a list -> ('a * 'a list) list +val group_by_post: ('a -> bool) -> 'a list -> ('a list * 'a) list * 'a list +val group_by_pre: ('a -> bool) -> 'a list -> 'a list * ('a * 'a list) list +val group_by_mapped_key: ('a -> 'b) -> 'a list -> ('b * 'a list) list +val group_and_count: 'a list -> ('a * int) list + +(* Use hash internally to not be in O(n2). If you want to use it on a + * simple list, then first do a List.map to generate a key, for instance the + * first char of the element, and then use this function. + *) +val group_assoc_bykey_eff : ('a * 'b) list -> ('a * 'b list) list + +val splitAt : int -> 'a list -> 'a list * 'a list + +val split_when: ('a -> bool) -> 'a list -> 'a list * 'a * 'a list +val split_gen_when: ('a list -> 'a list option) -> 'a list -> 'a list list + +(* return a list of with lots of chunks of size n *) +val pack : int -> 'a list -> 'a list list +val pack_safe: int -> 'a list -> 'a list list +(* return a list of size n which chunks from original list *) +val chunks: int -> 'a list -> 'a list list + + +val enum : int -> int -> int list +val enum_safe : int -> int -> int list +val repeat : 'a -> int -> 'a list +val generate : int -> 'a -> 'a list + + + +val index_list : 'a list -> ('a * int) list +val index_list_0 : 'a list -> ('a * int) list +val index_list_1 : 'a list -> ('a * int) list +val index_list_and_total : 'a list -> ('a * int * int) list + +val iter_index : ('a -> int -> 'b) -> 'a list -> unit +val map_index : ('a -> int -> 'b) -> 'a list -> 'b list +val filter_index : (int -> 'a -> bool) -> 'a list -> 'a list +val fold_left_with_index : ('a -> 'b -> int -> 'a) -> 'a -> 'b list -> 'a + +val nth : 'a list -> int -> 'a +val rang : (* Eq a *) 'a -> 'a list -> int + +val last_n : int -> 'a list -> 'a list + + + +val snoc : 'a -> 'a list -> 'a list +val cons : 'a -> 'a list -> 'a list +val uncons : 'a list -> 'a * 'a list +val safe_tl : 'a list -> 'a list +val head_middle_tail : 'a list -> 'a * 'a list * 'a +val list_last : 'a list -> 'a +val list_init : 'a list -> 'a list +val removelast : 'a list -> 'a list + +val inits : 'a list -> 'a list list +val tails : 'a list -> 'a list list + + +val ( ++ ) : 'a list -> 'a list -> 'a list + +val foldl1 : ('a -> 'a -> 'a) -> 'a list -> 'a +val fold_k : ('a -> 'b -> ('a -> 'a) -> 'a) -> ('a -> 'a) -> 'a -> 'b list -> 'a +val fold_right1 : ('a -> 'a -> 'a) -> 'a list -> 'a +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + +val rev_map : ('a -> 'b) -> 'a list -> 'b list + +val join_gen : 'a -> 'a list -> 'a list + +val do_withenv : + (('a -> 'b) -> 'c -> 'd) -> ('e -> 'a -> 'b * 'e) -> 'e -> 'c -> 'd * 'e +val map_withenv : ('a -> 'b -> 'c * 'a) -> 'a -> 'b list -> 'c list * 'a +val map_withkeep: ('a -> 'b) -> 'a list -> ('b * 'a) list + +val collect_accu : ('a -> 'b list) -> 'b list -> 'a list -> 'b list +val collect : ('a -> 'b list) -> 'a list -> 'b list + +val remove : 'a -> 'a list -> 'a list +val remove_first : 'a -> 'a list -> 'a list + +val exclude : ('a -> bool) -> 'a list -> 'a list + +(* Not like unix uniq command line tool that only delete contiguous repeated + * line. Here we delete any repeated line (here list element). + *) +val uniq : 'a list -> 'a list +val uniq_eff: 'a list -> 'a list +val big_union_eff: 'a list list -> 'a list + +val has_no_duplicate: 'a list -> bool +val is_set_as_list: 'a list -> bool +val get_duplicates: 'a list -> 'a list + +val doublon : 'a list -> bool + +val reverse : 'a list -> 'a list (* alias *) +val rev : 'a list -> 'a list (* alias *) +val rotate : 'a list -> 'a list + +val map_flatten : ('a -> 'b list) -> 'a list -> 'b list + +val map2 : ('a -> 'b) -> 'a list -> 'b list +val map3 : ('a -> 'b) -> 'a list -> 'b list + + +val maximum : 'a list -> 'a +val minimum : 'a list -> 'a + +val most_recurring_element: 'a list -> 'a +val count_elements_sorted_highfirst: 'a list -> ('a * int) list + +val min_with : ('a -> 'b) -> 'a list -> 'a +val two_mins_with : ('a -> 'b) -> 'a list -> 'a * 'a + +val all_assoc : (* Eq a *) 'a -> ('a * 'b) list -> 'b list +val prepare_want_all_assoc : ('a * 'b) list -> ('a * 'b list) list + +val or_list : bool list -> bool +val and_list : bool list -> bool + +val sum_float : float list -> float +val sum_int : int list -> int +val avg_list: int list -> float + +val return_when : ('a -> 'b option) -> 'a list -> 'b + + +val grep_with_previous : ('a -> 'a -> bool) -> 'a list -> 'a list +val iter_with_previous : ('a -> 'a -> 'b) -> 'a list -> unit +val iter_with_previous_opt : ('a option -> 'a -> 'b) -> 'a list -> unit + +val iter_with_before_after : + ('a list -> 'a -> 'a list -> unit) -> 'a list -> unit + +val get_pair : 'a list -> ('a * 'a) list + +val permutation : 'a list -> 'a list list + +val remove_elem_pos : int -> 'a list -> 'a list +val insert_elem_pos : ('a * int) -> 'a list -> 'a list +val uncons_permut : 'a list -> (('a * int) * 'a list) list +val uncons_permut_lazy : 'a list -> (('a * int) * 'a list Lazy.t) list + + +val pack_sorted : ('a -> 'a -> bool) -> 'a list -> 'a list list + +val keep_best : ('a * 'a -> 'a option) -> 'a list -> 'a list +val sorted_keep_best : ('a -> 'a -> 'a option) -> 'a list -> 'a list + + +val cartesian_product : 'a list -> 'b list -> ('a * 'b) list + +(* old stuff *) +val surEnsemble : 'a list -> 'a list list -> 'a list list +val realCombinaison : 'a list -> 'a list list +val combinaison : 'a list -> ('a * 'a) list +val insere : 'a -> 'a list list -> 'a list list +val insereListeContenant : 'a list -> 'a -> 'a list list -> 'a list list +val fusionneListeContenant : 'a * 'a -> 'a list list -> 'a list list +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Arrays *) +(*****************************************************************************) + +val array_find_index : (int -> bool) -> 'a array -> int +val array_find_index_via_elem : ('a -> bool) -> 'a array -> int + +(* for better type checking, as sometimes when have an 'int array', can + * easily mess up the index from the value. + *) +type idx = Idx of int +val next_idx: idx -> idx +val int_of_idx: idx -> int + +val array_find_index_typed : (idx -> bool) -> 'a array -> idx +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Fast array *) +(*****************************************************************************) + +(* ?? *) +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Matrix *) +(*****************************************************************************) + +type 'a matrix = 'a array array + +val map_matrix : ('a -> 'b) -> 'a matrix -> 'b matrix + +val make_matrix_init: + nrow:int -> ncolumn:int -> (int -> int -> 'a) -> 'a matrix + +val iter_matrix: + (int -> int -> 'a -> unit) -> 'a matrix -> unit + +val nb_rows_matrix: 'a matrix -> int +val nb_columns_matrix: 'a matrix -> int + +val rows_of_matrix: 'a matrix -> 'a list list +val columns_of_matrix: 'a matrix -> 'a list list + +val all_elems_matrix_by_row: 'a matrix -> 'a list +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Set. But have a look too at set*.mli; it's better. Or use Hashtbl. *) +(*****************************************************************************) + +type 'a set = 'a list + +val empty_set : 'a set + +val insert_set : 'a -> 'a set -> 'a set +val single_set : 'a -> 'a set +val set : 'a list -> 'a set + +val is_set: 'a list -> bool + +val exists_set : ('a -> bool) -> 'a set -> bool +val forall_set : ('a -> bool) -> 'a set -> bool + +val filter_set : ('a -> bool) -> 'a set -> 'a set +val fold_set : ('a -> 'b -> 'a) -> 'a -> 'b set -> 'a +val map_set : ('a -> 'b) -> 'a set -> 'b set + +val member_set : 'a -> 'a set -> bool +val find_set : ('a -> bool) -> 'a list -> 'a + +val sort_set : ('a -> 'a -> int) -> 'a list -> 'a list + +val iter_set : ('a -> unit) -> 'a list -> unit + +val top_set : 'a set -> 'a + +val inter_set : 'a set -> 'a set -> 'a set +val union_set : 'a set -> 'a set -> 'a set +val minus_set : 'a set -> 'a set -> 'a set + +val union_all : ('a set) list -> 'a set + +val big_union_set : ('a -> 'b set) -> 'a set -> 'b set +val card_set : 'a set -> int + +val include_set : 'a set -> 'a set -> bool +val equal_set : 'a set -> 'a set -> bool +val include_set_strict : 'a set -> 'a set -> bool + +(* could put them in Common.Infix *) +val ( $*$ ) : 'a set -> 'a set -> 'a set +val ( $+$ ) : 'a set -> 'a set -> 'a set +val ( $-$ ) : 'a set -> 'a set -> 'a set + +val ( $?$ ) : 'a -> 'a set -> bool +val ( $<$ ) : 'a set -> 'a set -> bool +val ( $<=$ ) : 'a set -> 'a set -> bool +val ( $=$ ) : 'a set -> 'a set -> bool + +val ( $@$ ) : 'a list -> 'a list -> 'a list + +val nub : 'a list -> 'a list + +(* use internally a hash and return + * - the common part, + * - part only in a, + * - part only in b + *) +val diff_set_eff : 'a list -> 'a list -> + 'a list * 'a list * 'a list +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Set as normal list *) +(*****************************************************************************) + +(* cf above *) +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Set as sorted list *) +(*****************************************************************************) +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Sets specialized *) +(*****************************************************************************) + +module StringSet : + sig + type elt = string + type t + val empty : t + val add : string -> t -> t + val remove : string -> t -> t + val singleton : string -> t + + val of_list: string list -> t + val to_list: t -> string list + + val is_empty : t -> bool + val mem : string -> t -> bool + + val union : t -> t -> t + val inter : t -> t -> t + val diff : t -> t -> t + + val subset : t -> t -> bool + val equal : t -> t -> bool + + val compare : t -> t -> int + val iter : (string -> unit) -> t -> unit + val fold : (string -> 'a -> 'a) -> t -> 'a -> 'a + val for_all : (string -> bool) -> t -> bool + val exists : (string -> bool) -> t -> bool + val filter : (string -> bool) -> t -> t + val partition : (string -> bool) -> t -> t * t + val cardinal : t -> int + val elements : t -> string list + (* + val min_string : t -> string + val max_string : t -> string + *) + val choose : t -> string + val split : string -> t -> t * bool * t + end + +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Assoc. But have a look too at Mapb.mli; it's better. Or use Hashtbl. *) +(*****************************************************************************) + +type ('a, 'b) assoc = ('a * 'b) list + +val assoc_to_function : (* Eq a *) ('a, 'b) assoc -> ('a -> 'b) + +val empty_assoc : ('a, 'b) assoc +val fold_assoc : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a +val insert_assoc : 'a -> 'a list -> 'a list +val map_assoc : ('a -> 'b) -> 'a list -> 'b list +val filter_assoc : ('a -> bool) -> 'a list -> 'a list + +val assoc : 'a -> ('a * 'b) list -> 'b + +val keys : ('a * 'b) list -> 'a list +val lookup : 'a -> ('a * 'b) list -> 'b + +val del_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list +val replace_assoc : 'a * 'b -> ('a * 'b) list -> ('a * 'b) list +val apply_assoc : 'a -> ('b -> 'b) -> ('a * 'b) list -> ('a * 'b) list + +val big_union_assoc : ('a -> 'b set) -> 'a list -> 'b set + +val assoc_reverse : ('a * 'b) list -> ('b * 'a) list +val assoc_map : ('a * 'b) list -> ('a * 'b) list -> ('a * 'a) list + +val lookup_list : 'a -> ('a, 'b) assoc list -> 'b +val lookup_list2 : 'a -> ('a, 'b) assoc list -> 'b * int + +val assoc_opt : 'a -> ('a, 'b) assoc -> 'b option +val assoc_with_err_msg : 'a -> ('a, 'b) assoc -> 'b + +type order = HighFirst | LowFirst +val compare_order: order -> 'a -> 'a -> int + +val sort_by_val_lowfirst: ('a,'b) assoc -> ('a * 'b) list +val sort_by_val_highfirst: ('a,'b) assoc -> ('a * 'b) list + +val sort_by_key_lowfirst: ('a,'b) assoc -> ('a * 'b) list +val sort_by_key_highfirst: ('a,'b) assoc -> ('a * 'b) list + +val sortgen_by_key_lowfirst: ('a,'b) assoc -> ('a * 'b) list +val sortgen_by_key_highfirst: ('a,'b) assoc -> ('a * 'b) list +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Assoc, specialized. *) +(*****************************************************************************) + +module IntMap : + sig + type key = int + type +'a t + val empty : 'a t + val is_empty : 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val find : key -> 'a t -> 'a + val remove : key -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val map : ('a -> 'b) -> 'a t -> 'b t + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + end +val intmap_to_list : 'a IntMap.t -> (IntMap.key * 'a) list +val intmap_string_of_t : 'a -> 'b -> string + +module IntIntMap : + sig + type key = int * int + type +'a t + val empty : 'a t + val is_empty : 'a t -> bool + val add : key -> 'a -> 'a t -> 'a t + val find : key -> 'a t -> 'a + val remove : key -> 'a t -> 'a t + val mem : key -> 'a t -> bool + val iter : (key -> 'a -> unit) -> 'a t -> unit + val map : ('a -> 'b) -> 'a t -> 'b t + val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int + val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + end +val intintmap_to_list : 'a IntIntMap.t -> (IntIntMap.key * 'a) list +val intintmap_string_of_t : 'a -> 'b -> string +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Hash *) +(*****************************************************************************) + +(* Note that Hashtbl keep old binding to a key so if want a hash + * of a list, then can use the Hashtbl as is. Use Hashtbl.find_all then + * to get the list of bindings + * + * Note that Hashtbl module use different convention :( the object is + * the first argument, not last as for List or Map. + *) + +(* obsolete: can use directly the Hashtbl module *) +val hcreate : unit -> ('a, 'b) Hashtbl.t +val hadd : 'a * 'b -> ('a, 'b) Hashtbl.t -> unit +val hmem : 'a -> ('a, 'b) Hashtbl.t -> bool +val hfind : 'a -> ('a, 'b) Hashtbl.t -> 'b +val hreplace : 'a * 'b -> ('a, 'b) Hashtbl.t -> unit +val hiter : ('a -> 'b -> unit) -> ('a, 'b) Hashtbl.t -> unit +val hfold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) Hashtbl.t -> 'c -> 'c +val hremove : 'a -> ('a, 'b) Hashtbl.t -> unit + + +val hfind_default : 'a -> (unit -> 'b) -> ('a, 'b) Hashtbl.t -> 'b +val hfind_option : 'a -> ('a, 'b) Hashtbl.t -> 'b option +val hupdate_default : + 'a -> update:('b -> 'b) -> default:(unit -> 'b) -> ('a, 'b) Hashtbl.t -> unit + +val add1: int -> int +val cst_zero: unit -> int + +val hash_to_list : ('a, 'b) Hashtbl.t -> ('a * 'b) list +val hash_to_list_unsorted : ('a, 'b) Hashtbl.t -> ('a * 'b) list +val hash_of_list : ('a * 'b) list -> ('a, 'b) Hashtbl.t + + +val hkeys : ('a, 'b) Hashtbl.t -> 'a list + +(* hunion h1 h2 adds all binding in h2 into h1 *) +val hunion: ('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t -> unit +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Hash sets *) +(*****************************************************************************) + +type 'a hashset = ('a, bool) Hashtbl.t + + +(* common use of hashset, in a hash of hash *) +val hash_hashset_add : 'a -> 'b -> ('a, 'b hashset) Hashtbl.t -> unit + +(* hashset_union h1 h2 adds all elements in h2 into h1 *) +val hashset_union: 'a hashset -> 'a hashset -> unit + +(* hashset_inter h1 h2 removes all elements in h1 not in h2 *) +val hashset_inter: 'a hashset -> 'a hashset -> unit + +val hashset_to_set : + < fromlist : ('a ) list -> 'c; .. > -> ('a, 'b) Hashtbl.t -> 'c + +val hashset_to_list : 'a hashset -> 'a list +val hashset_of_list : 'a list -> 'a hashset +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Hash with default value *) +(*****************************************************************************) +type ('a, 'b) hash_with_default = + < add : 'a -> 'b -> unit; + to_list : ('a * 'b) list; + to_h: ('a, 'b) Hashtbl.t; + update : 'a -> ('b -> 'b) -> unit; + assoc: 'a -> 'b; + > + +val hash_with_default: (unit -> 'b) -> + < add : 'a -> 'b -> unit; + to_list : ('a * 'b) list; + to_h: ('a, 'b) Hashtbl.t; + update : 'a -> ('b -> 'b) -> unit; + assoc: 'a -> 'b; + > +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Stack *) +(*****************************************************************************) + +type 'a stack = 'a list +val empty_stack : 'a stack +(*val push : 'a -> 'a stack -> 'a stack*) +val top : 'a stack -> 'a +val pop : 'a stack -> 'a stack + +val top_option: 'a stack -> 'a option + +val push : 'a -> 'a stack ref -> unit +val pop2: 'a stack ref -> 'a +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Stack with undo/redo support *) +(*****************************************************************************) + +type 'a undo_stack = 'a list * 'a list +val empty_undo_stack : 'a undo_stack +val push_undo : 'a -> 'a undo_stack -> 'a undo_stack +val top_undo : 'a undo_stack -> 'a +val pop_undo : 'a undo_stack -> 'a undo_stack +val redo_undo: 'a undo_stack -> 'a undo_stack +val undo_pop: 'a undo_stack -> 'a undo_stack + +val top_undo_option: 'a undo_stack -> 'a option +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Binary tree *) +(*****************************************************************************) +(* type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree) *) +(*x: common.mli for collection types *) +(*****************************************************************************) +(* N-ary tree *) +(*****************************************************************************) + +(* no empty tree, must have one root at least *) +type 'a tree2 = Tree of 'a * ('a tree2) list + +val tree2_iter : ('a -> unit) -> 'a tree2 -> unit + + +type ('a, 'b) tree = + | Node of 'a * ('a, 'b) tree list + | Leaf of 'b + +val map_tree: + fnode:('a -> 'abis) -> + fleaf:('b -> 'bbis) -> + ('a, 'b) tree -> ('abis, 'bbis) tree + +val dirs_and_base_of_file: path -> (string list * string) + +val tree_of_files: filename list -> (dirname, (string * filename)) tree + +(*x: common.mli for collection types *) +(*****************************************************************************) +(* N-ary tree with updatable childrens *) +(*****************************************************************************) + +(* no empty tree, must have one root at least *) +type 'a treeref = + | NodeRef of 'a * 'a treeref list ref + +val treeref_node_iter: + (('a * 'a treeref list ref) -> unit) -> 'a treeref -> unit +val treeref_node_iter_with_parents: + (('a * 'a treeref list ref) -> ('a list) -> unit) -> + 'a treeref -> unit + +val find_treeref: + (('a * 'a treeref list ref) -> bool) -> + 'a treeref -> 'a treeref + +val treeref_children_ref: + 'a treeref -> 'a treeref list ref + +val find_treeref_with_parents_some: + ('a * 'a treeref list ref -> 'a list -> 'c option) -> + 'a treeref -> 'c + +val find_multi_treeref_with_parents_some: + ('a * 'a treeref list ref -> 'a list -> 'c option) -> + 'a treeref -> 'c list + + +(* Leaf can seem redundant, but sometimes want to directly see if + * a children is a leaf without looking if the list is empty. + *) +type ('a, 'b) treeref2 = + | NodeRef2 of 'a * ('a, 'b) treeref2 list ref + | LeafRef2 of 'b + + +val find_treeref2: + (('a * ('a, 'b) treeref2 list ref) -> bool) -> + ('a, 'b) treeref2 -> ('a, 'b) treeref2 + +val treeref_node_iter_with_parents2: + (('a * ('a, 'b) treeref2 list ref) -> ('a list) -> unit) -> + ('a, 'b) treeref2 -> unit + +val treeref_node_iter2: + (('a * ('a, 'b) treeref2 list ref) -> unit) -> ('a, 'b) treeref2 -> unit + +(* + + +val treeref_children_ref: ('a, 'b) treeref -> ('a, 'b) treeref list ref + +val find_treeref_with_parents_some: + ('a * ('a, 'b) treeref list ref -> 'a list -> 'c option) -> + ('a, 'b) treeref -> 'c + +val find_multi_treeref_with_parents_some: + ('a * ('a, 'b) treeref list ref -> 'a list -> 'c option) -> + ('a, 'b) treeref -> 'c list +*) +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Graph. But have a look too at Ograph_*.mli; it's better *) +(*****************************************************************************) + +type 'a graph = 'a set * ('a * 'a) set + +val add_node : 'a -> 'a graph -> 'a graph +val del_node : 'a -> 'a graph -> 'a graph + +val add_arc : 'a * 'a -> 'a graph -> 'a graph +val del_arc : 'a * 'a -> 'a graph -> 'a graph + +val successors : 'a -> 'a graph -> 'a set +val predecessors : 'a -> 'a graph -> 'a set + +val nodes : 'a graph -> 'a set + +val fold_upward : ('a -> 'b -> 'a) -> 'b set -> 'a -> 'b graph -> 'a + +val empty_graph : 'a list * 'b list +(*x: common.mli for collection types *) +(*****************************************************************************) +(* Generic op *) +(*****************************************************************************) + +(* mostly alias to functions in List *) + +val map : ('a -> 'b) -> 'a list -> 'b list +val filter : ('a -> bool) -> 'a list -> 'a list +val fold : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a + +val member : 'a -> 'a list -> bool + +val iter : ('a -> unit) -> 'a list -> unit + +val find : ('a -> bool) -> 'a list -> 'a + +val exists : ('a -> bool) -> 'a list -> bool +val forall : ('a -> bool) -> 'a list -> bool + +val big_union : ('a -> 'b set) -> 'a list -> 'b set + +(* same than [] but easier to search for, because [] can also be a pattern *) +val empty_list : 'a list + +(* generic sort using Pervasives.compare *) +val sort : 'a list -> 'a list + +val length : 'a list -> int + +val null : 'a list -> bool + +val head : 'a list -> 'a +val tail : 'a list -> 'a list + +val is_singleton : 'a list -> bool + +(*e: common.mli for collection types *) + +(*###########################################################################*) +(* Misc functions *) +(*###########################################################################*) +(*s: common.mli misc *) + +(*xxxx*) + +(*s: common.mli misc other *) +(*****************************************************************************) +(* DB *) +(*****************************************************************************) + +(* cf oassocbdb.ml or oassocdbm.ml (LFS) *) + +(*****************************************************************************) +(* GUI *) +(*****************************************************************************) + +(* cf ocamlgtk and my gui.ml (LFS, CComment, otimetracker) *) + + +(*****************************************************************************) +(* Graphics *) +(*****************************************************************************) + +(* cf ocamlcairo, ocamlgl and my opengl.ml (otimetracker) *) + +(*e: common.mli misc other *) + +(*x: common.mli misc *) +(*****************************************************************************) +(* Geometry (ICFP raytracer) *) +(*****************************************************************************) + +type vector = float * float * float + +type point = vector +type color = vector + +val dotproduct : vector * vector -> float + +val vector_length : vector -> float + +val minus_point : point * point -> vector + +val distance : point * point -> float + +val normalise : vector -> vector + +val mult_coeff : vector -> float -> vector + +val add_vector : vector -> vector -> vector +val mult_vector : vector -> vector -> vector +val sum_vector : vector list -> vector +(*x: common.mli misc *) +(*****************************************************************************) +(* Pics (ICFP raytracer) *) +(*****************************************************************************) +type pixel = int * int * int +val write_ppm : int -> int -> pixel list -> filename -> unit +val test_ppm1 : unit -> unit +(*x: common.mli misc *) +(*****************************************************************************) +(* Diff (LFS) *) +(*****************************************************************************) + +type diff = Match | BnotinA | AnotinB +val diff : (int -> int -> diff -> unit) -> string list * string list -> unit +val diff2 : (int -> int -> diff -> unit) -> string * string -> unit + +(*****************************************************************************) +(* Grep (coccinelle) *) +(*****************************************************************************) + +val contain_any_token_with_egrep: string list -> filename -> bool + +(*x: common.mli misc *) +(*****************************************************************************) +(* Parsers (aop-colcombet) *) +(*****************************************************************************) + +val parserCommon : Lexing.lexbuf -> ('a -> Lexing.lexbuf -> 'b) -> 'a -> 'b +val getDoubleParser : + ('a -> Lexing.lexbuf -> 'b) -> 'a -> (string -> 'b) * (string -> 'b) +(*x: common.mli misc *) +(*****************************************************************************) +(* Parsers (cocci) *) +(*****************************************************************************) +(* now in h_program-lang/parse_info.ml *) +(*x: common.mli misc *) +(*****************************************************************************) +(* Scope managment (cocci) *) +(*****************************************************************************) + +(* for example of use, see the code used in coccinelle *) +type ('a, 'b) scoped_env = ('a, 'b) assoc list + +val lookup_env : (* Eq a *) 'a -> ('a, 'b) scoped_env -> 'b +val member_env_key : 'a -> ('a, 'b) scoped_env -> bool + +val new_scope : ('a, 'b) scoped_env ref -> unit +val del_scope : ('a, 'b) scoped_env ref -> unit + +val do_in_new_scope : ('a, 'b) scoped_env ref -> (unit -> unit) -> unit + +val add_in_scope : ('a, 'b) scoped_env ref -> 'a * 'b -> unit + + + + +(* for example of use, see the code used in coccinelle *) +type ('a, 'b) scoped_h_env = { + scoped_h : ('a, 'b) Hashtbl.t; + scoped_list : ('a, 'b) assoc list; +} +val empty_scoped_h_env : unit -> ('a, 'b) scoped_h_env +val clone_scoped_h_env : ('a, 'b) scoped_h_env -> ('a, 'b) scoped_h_env + +val lookup_h_env : 'a -> ('a, 'b) scoped_h_env -> 'b +val member_h_env_key : 'a -> ('a, 'b) scoped_h_env -> bool + +val new_scope_h : ('a, 'b) scoped_h_env ref -> unit +val del_scope_h : ('a, 'b) scoped_h_env ref -> unit + +val do_in_new_scope_h : ('a, 'b) scoped_h_env ref -> (unit -> unit) -> unit + +val add_in_scope_h : ('a, 'b) scoped_h_env ref -> 'a * 'b -> unit +(*x: common.mli misc *) +(*****************************************************************************) +(* Terminal (LFS) *) +(*****************************************************************************) +(* see console.ml *) + +(*e: common.mli misc *) + +(*****************************************************************************) +(* Gc optimisation (pfff) *) +(*****************************************************************************) + +(* opti: to avoid stressing the GC with a huge graph, we sometimes + * change a big AST into a string, which reduces the size of the graph + * to explore when garbage collecting. + *) +type 'a cached = 'a serialized_maybe ref + and 'a serialized_maybe = + | Serial of string + | Unfold of 'a + +val serial: 'a -> 'a cached +val unserial: 'a cached -> 'a + +(*###########################################################################*) +(* Postlude *) +(*###########################################################################*) +(*s: common.mli postlude *) +val cmdline_flags_devel : unit -> Common.cmdline_options +val cmdline_flags_verbose : unit -> Common.cmdline_options +val cmdline_flags_other : unit -> Common.cmdline_options + +val cmdline_actions : unit -> Common.cmdline_actions +(*e: common.mli postlude *) +(*e: common.mli *) diff --git a/commons/copyright.txt b/commons/copyright.txt new file mode 100644 index 0000000..6e5bfae --- /dev/null +++ b/commons/copyright.txt @@ -0,0 +1,17 @@ +Copyright (C) 1998-2018 Yoann Padioleau + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public License (LGPL) + version 2.1 as published by the Free Software Foundation, with the + special exception on linking described in file license.txt. + + This library 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 file + license.txt for more details. + + +The contents of some files in this directory was derived from external +sources with compatible licenses. The original copyright and license +notice was preserved in the affected files. + diff --git a/commons/credits.txt b/commons/credits.txt new file mode 100644 index 0000000..e63e626 --- /dev/null +++ b/commons/credits.txt @@ -0,0 +1,12 @@ +Thanks to + - Richard Jones for his dumper.ml module (public domain?) + - Jane Street for the backtrace module and lib-sexp/ (LGPL) + - Martin Jambon, Mika Illouz and Gert Stolpmann for lib-json/ (BSD-like) + - Nicolas Canasse for lib-xml/ (LGPL) + - Thomas Gazagnaire for dynType (BSD-like) + - Maas-Maarten Zeeman for OUnit (BSD-like) + - Thorsten Ohl for xHTML.ml (GPL) + - Brian Hurt and Nicolas Cannasse for their dynArray module (LGPL) + - Christophe Troestler for his ANSITerminal.ml module (LGPL) + - Sebastien ferre for his suffix tree module (public domain?) + - Anil Madhavapeddy for pretty_print_ident.ml (BSD-like) diff --git a/commons/deprecated/Makefile.old b/commons/deprecated/Makefile.old new file mode 100644 index 0000000..a63c8c9 --- /dev/null +++ b/commons/deprecated/Makefile.old @@ -0,0 +1,24 @@ +#----------------------------------------------------------------------------- +# Other stuff +#----------------------------------------------------------------------------- + +#backtrace +MYBACKTRACESRC=backtrace.ml +BACKTRACEINCLUDES=-I $(shell ocamlc -where) + +backtrace: commons_backtrace.cma +backtrace.opt: commons_backtrace.cmxa + +backtrace_c.o: backtrace_c.c + $(CC) $(BACKTRACEINCLUDES) -c $^ + +commons_backtrace.cma: $(MYBACKTRACESRC:.ml=.cmo) backtrace_c.o + $(OCAMLMKLIB) -o commons_backtrace $^ + +commons_backtrace.cmxa: $(MYBACKTRACESRC:.ml=.cmx) backtrace_c.o + $(OCAMLMKLIB) -o commons_backtrace $^ + + +clean:: + rm -f dllcommons_backtrace.so + diff --git a/commons/deprecated/backtrace.ml b/commons/deprecated/backtrace.ml new file mode 100644 index 0000000..d9bfe1b --- /dev/null +++ b/commons/deprecated/backtrace.ml @@ -0,0 +1,39 @@ +open Common + +(* + * src: Jane Street Core library. + * update: Normally no more needed in OCaml 3.11 as part of the + * default runtime. + *) +external print : unit -> unit = "print_exception_backtrace_stub" "noalloc" + + +(* ---------------------------------------------------------------------- *) +(* testing *) +(* ---------------------------------------------------------------------- *) + +exception MyNot_Found + +let foo1 () = + if 1=1 + then raise MyNot_Found + else 2 + +let foo2 () = + foo1 () + 2 + +let test_backtrace () = + (try ignore(foo2 ()) + with exn -> + pr2 (Common.exn_to_s exn); + print(); + failwith "other exn" + ); + print_string "ok cool\n"; + () + +let actions () = + [ + "-test_backtrace", " ", + Common.mk_action_0_arg test_backtrace; + ] diff --git a/commons/deprecated/backtrace_c.c b/commons/deprecated/backtrace_c.c new file mode 100644 index 0000000..67103cc --- /dev/null +++ b/commons/deprecated/backtrace_c.c @@ -0,0 +1,9 @@ +#include "caml/mlvalues.h" + +CAMLextern void caml_print_exception_backtrace(void); + +CAMLprim value print_exception_backtrace_stub(value /*__unused*/ unit) +{ + caml_print_exception_backtrace(); + return Val_unit; +} diff --git a/commons/deprecated/sexp_common.ml b/commons/deprecated/sexp_common.ml new file mode 100644 index 0000000..0cf1978 --- /dev/null +++ b/commons/deprecated/sexp_common.ml @@ -0,0 +1,48 @@ +(* automatically generated by ocamltarzan *) + +open Common + +let sexp_of_either _of_a _of_b = + function + | Left v1 -> let v1 = _of_a v1 in Sexp.List [ Sexp.Atom "Left"; v1 ] + | Right v1 -> let v1 = _of_b v1 in Sexp.List [ Sexp.Atom "Right"; v1 ] + +let sexp_of_either3 _of_a _of_b _of_c = + function + | Left3 v1 -> let v1 = _of_a v1 in Sexp.List [ Sexp.Atom "Left3"; v1 ] + | Middle3 v1 -> let v1 = _of_b v1 in Sexp.List [ Sexp.Atom "Middle3"; v1 ] + | Right3 v1 -> let v1 = _of_c v1 in Sexp.List [ Sexp.Atom "Right3"; v1 ] + + +let sexp_of_filename v = Conv.sexp_of_string v +let sexp_of_dirname v = Conv.sexp_of_string v + +let sexp_of_set _of_a = Conv.sexp_of_list _of_a + +let sexp_of_assoc _of_a _of_b = + Conv.sexp_of_list + (fun (v1, v2) -> + let v1 = _of_a v1 and v2 = _of_b v2 in Sexp.List [ v1; v2 ]) + +let sexp_of_hashset _of_a = Conv.sexp_of_hashtbl _of_a Conv.sexp_of_bool + +let sexp_of_stack _of_a = Conv.sexp_of_list _of_a + + + +let sexp_of_score_result = + function + | Common2.Ok -> Sexp.Atom "Ok" + | Common2.Pb v1 -> + let v1 = Conv.sexp_of_string v1 in Sexp.List [ Sexp.Atom "Pb"; v1 ] + +let sexp_of_score v = + Conv.sexp_of_hashtbl Conv.sexp_of_string sexp_of_score_result v + +let sexp_of_score_list v = + Conv.sexp_of_list + (fun (v1, v2) -> + let v1 = Conv.sexp_of_string v1 + and v2 = sexp_of_score_result v2 + in Sexp.List [ v1; v2 ]) + v diff --git a/commons/dumper.ml b/commons/dumper.ml new file mode 100644 index 0000000..1540da0 --- /dev/null +++ b/commons/dumper.ml @@ -0,0 +1,85 @@ +(* Dump an OCaml value into a printable string. + * By Richard W.M. Jones (rich@annexia.org). + * dumper.ml 1.2 2005/02/06 12:38:21 rich Exp + *) + +open Printf +open Obj + +let rec dump r = + if is_int r then + string_of_int (magic r : int) + else ( (* Block. *) + let rec get_fields acc = function + | 0 -> acc + | n -> let n = n-1 in get_fields (field r n :: acc) n + in + let rec is_list r = + if is_int r then ( + if (magic r : int) = 0 then true (* [] *) + else false + ) else ( + let s = size r and t = tag r in + if t = 0 && s = 2 then is_list (field r 1) (* h :: t *) + else false + ) + in + let rec get_list r = + if is_int r then [] + else let h = field r 0 and t = get_list (field r 1) in h :: t + in + let opaque name = + (* XXX In future, print the address of value 'r'. Not possible in + * pure OCaml at the moment. + *) + "<" ^ name ^ ">" + in + + let s = size r and t = tag r in + + (* From the tag, determine the type of block. *) + if is_list r then ( (* List. *) + let fields = get_list r in + "[" ^ String.concat "; " (List.map dump fields) ^ "]" + ) + else if t = 0 then ( (* Tuple, array, record. *) + let fields = get_fields [] s in + "(" ^ String.concat ", " (List.map dump fields) ^ ")" + ) + + (* Note that [lazy_tag .. forward_tag] are < no_scan_tag. Not + * clear if very large constructed values could have the same + * tag. XXX *) + else if t = lazy_tag then opaque "lazy" + else if t = closure_tag then opaque "closure" + else if t = object_tag then ( (* Object. *) + let fields = get_fields [] s in + let clasz, id, slots = + match fields with h::h'::t -> h, h', t | _ -> assert false in + (* No information on decoding the class (first field). So just print + * out the ID and the slots. + *) + "Object #" ^ dump id ^ + " (" ^ String.concat ", " (List.map dump slots) ^ ")" + ) + else if t = infix_tag then opaque "infix" + else if t = forward_tag then opaque "forward" + + else if t < no_scan_tag then ( (* Constructed value. *) + let fields = get_fields [] s in + "Tag" ^ string_of_int t ^ + " (" ^ String.concat ", " (List.map dump fields) ^ ")" + ) + else if t = string_tag then ( + "\"" ^ String.escaped (magic r : string) ^ "\"" + ) + else if t = double_tag then ( + string_of_float (magic r : float) + ) + else if t = abstract_tag then opaque "abstract" + else if t = custom_tag then opaque "custom" + else if t = final_tag then opaque "final" + else failwith ("dump: impossible tag (" ^ string_of_int t ^ ")") + ) + +let dump v = dump (repr v) diff --git a/commons/dumper.mli b/commons/dumper.mli new file mode 100644 index 0000000..d74853b --- /dev/null +++ b/commons/dumper.mli @@ -0,0 +1,6 @@ +(* Dump an OCaml value into a printable string. + * By Richard W.M. Jones (rich@annexia.org). + * dumper.mli 1.1 2005/02/03 23:07:47 rich Exp + *) + +val dump : 'a -> string diff --git a/commons/features.ml b/commons/features.ml new file mode 100644 index 0000000..e69de29 diff --git a/commons/file_type.ml b/commons/file_type.ml new file mode 100644 index 0000000..ecf399a --- /dev/null +++ b/commons/file_type.ml @@ -0,0 +1,323 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010-2013 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* see also dircolors.el and LFS *) +type file_type = + | PL of pl_type + | Obj of string (* .o, .a, .aux, .bak, etc *) + | Binary of string + | Text of string (* tex, txt, readme, noweb, org, etc *) + | Doc of string (* ps, pdf *) + | Media of media_type + | Archive of string (* tgz, rpm, etc *) + | Other of string + + and pl_type = + | ML of string (* mli, ml, mly, mll *) + | Haskell of string + | Lisp of lisp_type + | Prolog of string + | Makefile + | Script of string (* sh, csh, awk, sed, etc *) + | C of string | Cplusplus of string | ObjectiveC of string + | Java | Csharp + | Perl | Python | Ruby | Lua + | Erlang | Go | Rust + | Beta + | Pascal + | Haxe | Opa | Flash + | Web of webpl_type + | Bytecode of string + | Asm + | Thrift + | MiscPL of string + + and lisp_type = CommonLisp | Elisp | Scheme + + and webpl_type = + | Php of string (* php or phpt or script *) + | Js | Coffee + | Css + | Html | Xml | Json + | Sql + + and media_type = + | Sound of string + | Picture of string + | Video of string + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +(* this function is used by codemap and archi_parse and called for each + * filenames, so it has to be fast! + *) +let file_type_of_file2 file = + let (d,b,e) = Common2.dbe_of_filename_noext_ok file in + match e with + + | "ml" | "mli" + | "mly" | "mll" + -> PL (ML e) + | "mlb" (* mlburg *) + | "mlp" (* used in some source *) + | "eliom" (* ocsigen, obviously *) + -> PL (ML e) + + | "sml" -> PL (ML e) + (* fsharp *) + | "fsi" | "fsx" | "fs" -> PL (ML e) + (* linear ML *) + | "lml" -> PL (ML e) + + | "hs" | "lhs" -> PL (Haskell e) + + | "erl" | "hrl" -> PL Erlang + + | "hx" | "hxp" | "hxml" -> PL Haxe + | "opa" -> PL Opa + + | "as" -> PL Flash + + | "bet" -> PL Beta + + (* todo detect false C file, look for "Mode: Objective-C++" string in file ? + * can also be a c++, use Parser_cplusplus.is_problably_cplusplus_file + *) + | "c" -> PL (C e) + | "h" -> PL (C e) + (* todo? have a PL of xxx_kind * pl_kind ? *) + | "y" | "l" -> PL (C e) + + | "hpp" -> PL (Cplusplus e) | "hxx" -> PL (Cplusplus e) + | "hh" -> PL (Cplusplus e) + | "cpp" -> PL (Cplusplus e) | "C" -> PL (Cplusplus e) + | "cc" -> PL (Cplusplus e) | "cxx" -> PL (Cplusplus e) + (* used in libstdc++ *) + | "tcc" -> PL (Cplusplus e) + + | "m" | "mm" -> PL (ObjectiveC e) + + | "java" -> PL Java + | "cs" -> PL Csharp + + | "p" -> PL Pascal + + | "thrift" -> PL Thrift + + | "scm" | "rkt" | "ss" | "lsp" -> PL (Lisp Scheme) + | "lisp" -> PL (Lisp CommonLisp) + | "el" -> PL (Lisp Elisp) + + (* Perl or Prolog ... I made my choice *) + | "pl" -> PL (Prolog "pl") + | "logic" -> PL (Prolog "logic") (* datalog of logicblox *) + | "dtl" -> PL (Prolog "dtl") (* bddbddb *) + | "dl" -> PL (Prolog "dl") (* datalog *) + | "perl" -> PL Perl + | "py" -> PL Python + | "rb" -> PL Ruby + + | "clp" -> PL (Prolog e) + + | "s" | "S" | "asm" -> PL Asm + + | "c--" -> PL (MiscPL e) + | "oz" -> PL (MiscPL e) + | "R" | "Rd" -> PL (MiscPL e) + + | "scala" -> PL (MiscPL e) + | "groovy" -> PL (MiscPL e) + + | "sh" | "rc" | "csh" | "bash" -> PL (Script e) + | "m4" -> PL (MiscPL e) + | "conf" -> PL (MiscPL e) + + (* Andrew Appel's Tiger toy language *) + | "tig" -> PL (MiscPL e) + + (* merd *) + | "me" -> PL (MiscPL "me") + + | "vim" -> PL (MiscPL "vim") + | "nanorc" -> PL (MiscPL "nanorc") + + (* from hex to bcc *) + | "he" -> PL (MiscPL "he") + | "bc" -> PL (MiscPL "bc") + + | "php" | "phpt" -> PL (Web (Php e)) + | "css" -> PL (Web Css) + (* "javascript" | "es" | ? *) + | "js" -> PL (Web Js) + | "coffee" -> PL (Web Coffee) + | "html" | "htm" -> PL (Web Html) + | "xml" -> PL (Web Xml) + | "json" -> PL (Web Json) + | "sql" -> PL (Web Sql) + | "sqlite" -> PL (Web Sql) + + (* apple stuff ? *) + | "xib" -> PL (Web Xml) + (* xml i18n stuff for apple *) + | "nib" -> Obj e + + (* facebook: sqlshim files *) + | "sql3" -> PL (Web Sql) + | "fbobj" -> PL (MiscPL "fbobj") + + | "png" | "jpg" | "JPG" | "gif" | "tiff" -> Media (Picture e) + | "xcf" | "xpm" -> Media (Picture e) + | "icns" | "icon" | "ico" -> Media (Picture e) + | "ppm" -> Media (Picture e) + | "tga" -> Media (Picture e) + | "ttf" | "font" -> Media (Picture e) + + | "wav" -> Media (Sound e) + + | "swf" -> Media (Picture e) + + + | "ps" | "pdf" -> Doc e + | "ppt" -> Doc e + + | "tex" | "texi" -> Text e + | "txt" | "doc" -> Text e + | "nw" | "web" -> Text e + | "ms" -> Text e + + | "org" + | "md" | "rest" | "textile" | "wiki" | "rst" + -> Text e + + | "rtf" -> Text e + + | "cmi" | "cmo" | "cmx" | "cma" | "cmxa" + | "annot" | "cmt" | "cmti" + | "o" | "a" + | "pyc" + | "log" + | "toc" | "brf" + | "out" | "output" + | "hi" + | "msi" + -> Obj e + (* pad: I use it to store marshalled data *) + | "db" -> Obj e + | "po" | "pot" | "gmo" -> Obj e + (* facebook fbcode stuff *) + | "apcarc" | "serialized" | "wsdl" | "dat" | "train" -> Obj e + | "facts" -> Obj e (* logicblox *) + (* pad specific, cached git blame info *) + | "git_annot" -> Obj e + (* pad specific, codegraph cached data *) + | "marshall" | "matrix" -> Obj e + + | "byte" | "top" -> Binary e + + | "tar" -> Archive e + | "tgz" -> Archive e + + (* was PL Bytecode, but more accurate as an Obj *) + | "class" -> Obj e + (* pad specific, clang ast dump *) + | "clang" | "c.clang2" | "h.clang2" | "clang2" -> Obj e + + (* was Archive *) + | "jar" -> Archive e + + | "bz2" -> Archive e + | "gz" -> Archive e + | "rar" -> Archive e + | "zip" -> Archive e + + + | "exe" -> Binary e + | "mk" -> PL Makefile + + | "rs" -> PL Rust + | "go" -> PL Go + | "lua" -> PL Lua + + | _ when Common2.is_executable file -> Binary e + + | _ when b = "Makefile" || b = "mkfile" || b = "Imakefile" -> PL Makefile + | _ when b = "README" -> Text "txt" + + | _ when b = "TAGS" -> Binary e + | _ when b = "TARGETS" -> PL Makefile + | _ when b = ".depend" -> Obj "depend" + | _ when b = ".emacs" -> PL (Lisp (Elisp)) + + | _ when Common2.filesize file > 300_000 -> Obj e + | _ -> Other e + +let file_type_of_file a = + Common.profile_code "file_type_of_file" (fun () -> file_type_of_file2 a) + + + +(*****************************************************************************) +(* Misc *) +(*****************************************************************************) + +let is_textual_file file = + match file_type_of_file file with + (* if this contains weird code then pfff_visual crash *) + | PL (Web Sql) -> false + + | PL _ + | Text _ -> true + | _ -> false + +let webpl_type_of_file file = + match file_type_of_file file with + | PL (Web x) -> Some x + | _ -> None + + +(* +let detect_pl_of_file file = + raise Todo + +let string_of_pl x = + raise Todo + | C -> "c" + | Cplusplus -> "c++" + | Java -> "java" + + | Web _ -> raise Todo +*) + +let is_syncweb_obj_file file = + file =~ ".*md5sum_" + +let is_json_filename filename = + filename =~ ".*\\.json$" + (* + match File_type.file_type_of_file filename with + | File_type.PL (File_type.Web (File_type.Json)) -> true + | _ -> false + *) diff --git a/commons/file_type.mli b/commons/file_type.mli new file mode 100644 index 0000000..4345043 --- /dev/null +++ b/commons/file_type.mli @@ -0,0 +1,58 @@ + +type file_type = + | PL of pl_type + | Obj of string + | Binary of string + | Text of string + | Doc of string + | Media of media_type + | Archive of string + | Other of string + + and pl_type = + | ML of string | Haskell of string | Lisp of lisp_type + | Prolog of string + | Makefile + | Script of string + | C of string | Cplusplus of string | ObjectiveC of string | Java | Csharp + | Perl | Python | Ruby | Lua + | Erlang | Go | Rust + | Beta + | Pascal + | Haxe | Opa | Flash + | Web of webpl_type + | Bytecode of string + | Asm + | Thrift + | MiscPL of string + + and lisp_type = CommonLisp | Elisp | Scheme + + and webpl_type = + | Php of string + | Js | Coffee + | Css + | Html | Xml | Json + | Sql + + and media_type = + | Sound of string + | Picture of string + | Video of string + + +val file_type_of_file: + Common.filename -> file_type + +val is_textual_file: + Common.filename -> bool +val is_syncweb_obj_file: + Common.filename -> bool +val is_json_filename: + Common.filename -> bool + +(* specialisations *) +val webpl_type_of_file: + Common.filename -> webpl_type option + +(* val string_of_pl: pl_kind -> string *) diff --git a/commons/license.txt b/commons/license.txt new file mode 100644 index 0000000..67b72ca --- /dev/null +++ b/commons/license.txt @@ -0,0 +1,520 @@ +The Library is distributed under the terms of the GNU Lesser General +Public License version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute that +executable file under terms of your choice, without any of the additional +requirements listed in clause 6 of the GNU Lesser General Public License. +By "a publicly distributed version of the Library", we mean either the +unmodified Library as distributed by the authors, or a modified version +of the Library that is distributed under the conditions defined in clause +3 of the GNU Lesser General Public License. This exception does not +however invalidate any other reasons why the executable file might be +covered by the GNU Lesser General Public License. + +--------------------------------------------------------------------------- + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/commons/map_.ml b/commons/map_.ml new file mode 100644 index 0000000..01712a2 --- /dev/null +++ b/commons/map_.ml @@ -0,0 +1,152 @@ +(*pad: same than for Setb, module Make(Ord: OrderedType) = struct *) + +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* map.ml 1.15 2004/04/23 10:01:33 xleroy Exp *) + +(* + type key = Ord.t + + type 'a t = + Empty + | Node of 'a t * key * 'a * 'a t * int +*) + type ('key, 'v) t = + Empty + | Node of ('key, 'v) t * 'key * 'v * ('key, 'v) t * int + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + 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 rec add x data = function + Empty -> + Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) -> + let c = compare x v in + if c = 0 then + Node(l, x, data, r, h) + else if c < 0 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, _) -> + let c = compare x v in + if c = 0 then d + else find x (if c < 0 then l else r) + + let rec mem x = function + Empty -> + false + | Node(l, v, d, r, _) -> + let c = compare x v in + c = 0 || mem x (if c < 0 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) -> + let c = compare x v in + if c = 0 then + merge l r + else if c < 0 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)) + +(* addons pad *) +let of_list xs = + List.fold_left (fun acc (k, v) -> add k v acc) empty xs + +let to_list t = + fold (fun k v acc -> (k,v)::acc) t [] diff --git a/commons/map_.mli b/commons/map_.mli new file mode 100644 index 0000000..8427347 --- /dev/null +++ b/commons/map_.mli @@ -0,0 +1,123 @@ +(*pad: taken from map.ml from stdlib ocaml, functor sux: module Make(Ord: OrderedType) = *) +(***********************************************************************) +(* *) +(* 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: map.mli,v 1.33.18.1 2009/03/21 16:35:48 xleroy Exp $ *) + +(** 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. +*) + +(* pad: +module type OrderedType = + sig + type t + (** The type of the map keys. *) + val compare : t -> t -> int + (** A total ordering function over the keys. + This is a two-argument function [f] such that + [f e1 e2] is zero if the keys [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 {!Map.Make}. *) +*) +(* +module type S = + sig +*) + (* type key *) + (** The type of the map keys. *) + + (*type (+'a) t *) + type ('key, 'a) t + (** The type of maps from type [key] to type ['a]. *) + + val empty: ('key, 'a) t + (** The empty map. *) + + val is_empty: ('key, 'a) t -> bool + (** Test whether a map is empty or not. *) + + val add: 'key -> 'a -> ('key, 'a) t -> ('key, '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: 'key -> ('key, '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: 'key -> ('key, 'a) t -> ('key, '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: 'key -> ('key, 'a) t -> bool + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + + val iter: ('key -> 'a -> unit) -> ('key, '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. *) + + val map: ('a -> 'b) -> ('key, 'a) t -> ('key, '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: ('key -> 'a -> 'b) -> ('key, 'a) t -> ('key, '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: ('key -> 'a -> 'b -> 'b) -> ('key, '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) -> ('key, 'a) t -> ('key, '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) -> ('key, 'a) t -> ('key, '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. *) +*) +(* + end +(** Output signature of the functor {!Map.Make}. *) + +module Make (Ord : OrderedType) : S with type key = Ord.t +(** Functor building an implementation of the map structure + given a totally ordered type. *) + + +*) + +(* addons pad *) + val of_list: ('key * 'a) list -> ('key, 'a) t + val to_list: ('key, 'a) t -> ('key * 'a) list diff --git a/commons/oUnit.ml b/commons/oUnit.ml new file mode 100644 index 0000000..32ff999 --- /dev/null +++ b/commons/oUnit.ml @@ -0,0 +1,462 @@ +(***********************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 *) +(* Maas-Maarten Zeeman. *) + +(* +The package OUnit is copyright by Maas-Maarten Zeeman. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this document and the OUnit software ("the Software"), to +deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, +sublicense, and/or sell copies of the Software, and to permit persons +to whom the Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +The Software is provided ``as is'', without warranty of any kind, +express or implied, including but not limited to the warranties of +merchantability, fitness for a particular purpose and noninfringement. +In no event shall Maas-Maarten Zeeman be liable for any claim, damages +or other liability, whether in an action of contract, tort or +otherwise, arising from, out of or in connection with the Software or +the use or other dealings in the software. +*) + +(***********************************************************************) +(* pad: just harmonized some APIs regarding the 'msg' label *) + +let bracket set_up f tear_down () = + let fixture = set_up () in + try + f fixture; + tear_down fixture + with + e -> + tear_down fixture; + raise e + +exception Skip of string +let skip_if b msg = + if b then + raise (Skip msg) + +exception Todo of string +let todo msg = + raise (Todo msg) + +let assert_failure msg = + failwith ("OUnit: " ^ msg) + +let assert_bool ~msg b = + if not b then assert_failure msg + +let assert_string str = + if not (str = "") then assert_failure str + +let assert_equal ?(cmp = ( = )) ?printer ?msg expected actual = + (* pad: better to use dump by default *) + let p = Dumper.dump in + + let get_error_string _ = + match printer, msg with + None, None -> + (Format.sprintf "expected: %s but got: %s" + (p expected) (p actual)) + | None, Some s -> + (Format.sprintf "%s\nnot equal, expected: %s but got: %s" s + (p expected) (p actual)) + | Some p, None -> (Format.sprintf "expected: %s but got: %s" + (p expected) (p actual)) + | Some p, Some s -> (Format.sprintf "%s\nexpected: %s but got: %s" + s (p expected) (p actual)) + in + if not (cmp expected actual) then + assert_failure (get_error_string ()) + +let raises f = + try + f (); + None + with + e -> Some e + +let assert_raises ?msg exn (f: unit -> 'a) = + let pexn = Printexc.to_string in + let get_error_string _ = + let str = Format.sprintf + "expected exception %s, but no exception was raised." (pexn exn) + in + match msg with + None -> assert_failure str + | Some s -> assert_failure (Format.sprintf "%s\n%s" s str) + in + match raises f with + None -> assert_failure (get_error_string ()) + | Some e -> assert_equal ?msg ~printer:pexn exn e + +(* Compare floats up to a given relative error *) +let cmp_float ?(epsilon = 0.00001) a b = + abs_float (a -. b) <= epsilon *. (abs_float a) || + abs_float (a -. b) <= epsilon *. (abs_float b) + +(* Now some handy shorthands *) +let (@?) msg a = assert_bool msg a + +(* The type of test function *) +type test_fun = unit -> unit + +(* The type of tests *) +type test = + TestCase of test_fun + | TestList of test list + | TestLabel of string * test + +(* Some shorthands which allows easy test construction *) +let (>:) s t = TestLabel(s, t) (* infix *) +let (>::) s f = TestLabel(s, TestCase(f)) (* infix *) +let (>:::) s l = TestLabel(s, TestList(l)) (* infix *) + +(* Utility function to manipulate test *) +let rec test_decorate g tst = + match tst with + | TestCase f -> + TestCase (g f) + | TestList tst_lst -> + TestList (List.map (test_decorate g) tst_lst) + | TestLabel (str, tst) -> + TestLabel (str, test_decorate g tst) + +(* Return the number of available tests *) +let rec test_case_count test = + match test with + TestCase _ -> 1 + | TestLabel (_, t) -> test_case_count t + | TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l + +type node = ListItem of int | Label of string +type path = node list + +let string_of_node node = + match node with + ListItem n -> (string_of_int n) + | Label s -> s + +let string_of_path path = + List.fold_left + (fun a l -> + if a = "" then + l + else + l ^ ":" ^ a) "" (List.map string_of_node path) + +(* Some helper function, they are generally applicable *) +(* Applies function f in turn to each element in list. Function f takes + one element, and integer indicating its location in the list *) +let mapi f l = + let rec rmapi cnt l = + match l with + [] -> [] + | h::t -> (f h cnt)::(rmapi (cnt + 1) t) + in + rmapi 0 l + +let fold_lefti f accu l = + let rec rfold_lefti cnt accup l = + match l with + [] -> accup + | h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t + in + rfold_lefti 0 accu l + +(* Returns all possible paths in the test. The order is from test case + to root +*) +let test_case_paths test = + let rec tcps path test = + match test with + TestCase _ -> [path] + | TestList tests -> + List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests) + | TestLabel (l, t) -> tcps ((Label l)::path) t + in + tcps [] test + +(* Test filtering with their path *) +module SetTestPath = Set.Make(String) + +let test_filter only test = + let set_test = + List.fold_left + (fun st str -> SetTestPath.add str st) + SetTestPath.empty + only + in + let foldi f acc lst = + List.fold_left + (fun (i, acc) e -> + let nacc = + f i acc e + in + (i + 1), nacc + ) + acc + lst + in + let rec filter_test path tst = + if SetTestPath.mem (string_of_path path) set_test then + ( + Some tst + ) + else + ( + match tst with + | TestCase _ -> + None + | TestList tst_lst -> + let (_, ntst_lst) = + foldi + (fun i ntst_lst tst -> + let nntst_lst = + match filter_test ((ListItem i) :: path) tst with + | Some tst -> + tst :: ntst_lst + | None -> + ntst_lst + in + nntst_lst + ) + (0, []) + tst_lst + in + if ntst_lst = [] then + None + else + Some (TestList ntst_lst) + | TestLabel (lbl, tst) -> + let ntst = + filter_test + ((Label lbl) :: path) + tst + in + match ntst with + | Some tst -> + Some (TestLabel (lbl, tst)) + | None -> + None + ) + in + filter_test [] test + + +(* The possible test results *) +type test_result = + RSuccess of path + | RFailure of path * string + | RError of path * string + | RSkip of path * string + | RTodo of path * string + +let is_success = function + RSuccess _ -> true + | RFailure _ | RError _ | RSkip _ | RTodo _ -> false + +let is_failure = function + RFailure _ -> true + | RSuccess _ | RError _ | RSkip _ | RTodo _ -> false + +let is_error = function + RError _ -> true + | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false + +let is_skip = function + RSkip _ -> true + | RSuccess _ | RFailure _ | RError _ | RTodo _ -> false + +let is_todo = function + RTodo _ -> true + | RSuccess _ | RFailure _ | RError _ | RSkip _ -> false + +let result_flavour = function + RError _ -> "Error" + | RFailure _ -> "Failure" + | RSuccess _ -> "Success" + | RSkip _ -> "Skip" + | RTodo _ -> "Todo" + +let result_path = function + RSuccess path + | RError (path, _) + | RFailure (path, _) + | RSkip (path, _) + | RTodo (path, _) -> path + +let result_msg = function + RSuccess _ -> "Success" + | RError (_, msg) + | RFailure (_, msg) + | RSkip (_, msg) + | RTodo (_, msg) -> msg + +(* Returns true if the result list contains successes only *) +let rec was_successful results = + match results with + [] -> true + | RSuccess _::t + | RSkip _::t -> was_successful t + | RFailure _::_ + | RError _::_ + | RTodo _::_ -> false + +(* Events which can happen during testing *) +type test_event = + EStart of path + | EEnd of path + | EResult of test_result + +(* Run all tests, report starts, errors, failures, and return the results *) +let perform_test report test = + let run_test_case f path = + try + f (); + RSuccess path + with + Failure s -> RFailure (path, s) + | Skip s -> RSkip (path, s) + | Todo s -> RTodo (path, s) + | s -> RError (path, (Printexc.to_string s ^ " " ^ + Printexc.get_backtrace ())) + in + let rec run_test path results test = + match test with + TestCase(f) -> + report (EStart path); + let result = run_test_case f path in + report (EResult result); + report (EEnd path); + result::results + | TestList (tests) -> + fold_lefti + (fun results t cnt -> run_test ((ListItem cnt)::path) results t) + results tests + | TestLabel (label, t) -> + run_test ((Label label)::path) results t + in + run_test [] [] test + +(* Function which runs the given function and returns the running time + of the function, and the original result in a tuple *) +let time_fun f x y = + let begin_time = Unix.gettimeofday () in + (Unix.gettimeofday () -. begin_time, f x y) + +(* A simple (currently too simple) text based test runner *) +let run_test_tt ?(verbose=false) test = + let printf = Format.printf in + let separator1 = + "======================================================================" in + let separator2 = + "----------------------------------------------------------------------" in + let string_of_result = function + RSuccess _ -> + if verbose then "ok\n" else "." + | RFailure (_, _) -> + if verbose then "FAIL\n" else "F" + | RError (_, _) -> + if verbose then "ERROR\n" else "E" + | RSkip (_, _) -> + if verbose then "SKIP\n" else "S" + | RTodo (_, _) -> + if verbose then "TODO\n" else "T" + in + let report_event = function + EStart p -> + if verbose then printf "%s ... " (string_of_path p) + | EEnd _ -> () + | EResult result -> + printf "%s@?" (string_of_result result); + in + let print_result_list results = + List.iter + (fun result -> printf "%s\n%s: %s\n\n%s\n%s\n" + separator1 + (result_flavour result) + (string_of_path (result_path result)) + (result_msg result) + separator2) + results + in + + (* Now start the test *) + let running_time, results = time_fun perform_test report_event test in + let errors = List.filter is_error results in + let failures = List.filter is_failure results in + let skips = List.filter is_skip results in + let todos = List.filter is_todo results in + + if not verbose then printf "\n"; + + (* Print test report *) + print_result_list errors; + print_result_list failures; + printf "Ran: %d tests in: %.2f seconds.\n" + (List.length results) running_time; + + (* Print final verdict *) + if was_successful results then + ( + if skips = [] then + printf "OK" + else + printf "OK: Cases: %d Skip: %d\n" + (test_case_count test) (List.length skips) + ) + else + printf "FAILED: Cases: %d Tried: %d Errors: %d Failures: %d Skip:%d Todo:%d\n" + (test_case_count test) (List.length results) + (List.length errors) (List.length failures) + (List.length skips) (List.length todos); + + (* Return the results possibly for further processing *) + results + +(* Call this one from you test suites *) +let run_test_tt_main suite = + let verbose = ref false in + let only_test = ref [] in + + Arg.parse + (Arg.align + [("-verbose", Arg.Set verbose, " Run the test in verbose mode."); + ("-only-test", Arg.String (fun str -> only_test := str :: !only_test), + "path Run only the selected test"); + ] + ) + (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) + ("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*"); + + let nsuite = + if !only_test = [] then + ( + suite + ) + else + ( + match test_filter !only_test suite with + | Some tst -> + tst + | None -> + failwith ("Filtering test "^ + (String.concat ", " !only_test)^ + " lead to no test") + ) + in + let result = run_test_tt ~verbose:!verbose nsuite in + if not (was_successful result) then + exit 1 + else + result diff --git a/commons/oUnit.mli b/commons/oUnit.mli new file mode 100644 index 0000000..5f7f66a --- /dev/null +++ b/commons/oUnit.mli @@ -0,0 +1,202 @@ +(***********************************************************************) +(* The OUnit library *) +(* *) +(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 *) +(* Maas-Maarten Zeeman. *) + +(* +The package OUnit is copyright by Maas-Maarten Zeeman. + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this document and the OUnit software ("the Software"), to +deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, +sublicense, and/or sell copies of the Software, and to permit persons +to whom the Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +The Software is provided ``as is'', without warranty of any kind, +express or implied, including but not limited to the warranties of +merchantability, fitness for a particular purpose and noninfringement. +In no event shall Maas-Maarten Zeeman be liable for any claim, damages +or other liability, whether in an action of contract, tort or +otherwise, arising from, out of or in connection with the Software or +the use or other dealings in the software. +*) +(***********************************************************************) + +(** The OUnit library can be used to implement unittests + + To uses this library link with + [ocamlc oUnit.cmo] + or + [ocamlopt oUnit.cmx] + + @author Maas-Maarten Zeeman +*) + +(** {5 Assertions} + + Assertions are the basic building blocks of unittests. *) + +(** Signals a failure. This will raise an exception with the specified + string. + + @raise Failure to signal a failure *) +val assert_failure : string -> 'a + +(** Signals a failure when bool is false. The string identifies the + failure. + + @raise Failure to signal a failure *) +val assert_bool : msg:string -> bool -> unit + +(** Shorthand for assert_bool + + @raise Failure to signal a failure *) +val ( @? ) : string -> bool -> unit + +(** Signals a failure when the string is non-empty. The string identifies the + failure. + + @raise Failure to signal a failure *) +val assert_string : string -> unit + + +(** Compares two values, when they are not equal a failure is signaled. + The cmp parameter can be used to pass a different compare function. + This parameter defaults to ( = ). The optional printer can be used + to convert the value to string, so a nice error message can be + formatted. When msg is also set it can be used to identify the failure. + + @raise Failure description *) +val assert_equal : ?cmp:('a -> 'a -> bool) -> ?printer:('a -> string) -> + ?msg:string -> 'a -> 'a -> unit + +(** Asserts if the expected exception was raised. When msg is set it can + be used to identify the failure + + @raise Failure description *) +val assert_raises : ?msg:string -> exn -> (unit -> 'a) -> unit + +(** {5 Skipping tests } + + In certain condition test can be written but there is no point running it, because they + are not significant (missing OS features for example). In this case this is not a failure + nor a success. Following function allow you to escape test, just as assertion but without + the same error status. + + A test skipped is counted as success. A test todo is counted as failure. *) + +(** [skip cond msg] If [cond] is true, skip the test for the reason explain in [msg]. + * For example [skip_if (Sys.os_type = "Win32") "Test a doesn't run on windows"]. + *) +val skip_if : bool -> string -> unit + +(** The associated test is still to be done, for the reason given. + *) +val todo : string -> unit + +(** {5 Compare Functions} *) + +(** Compare floats up to a given relative error. *) +val cmp_float : ?epsilon: float -> float -> float -> bool + +(** {5 Bracket} + + A bracket is a functional implementation of the commonly used + setUp and tearDown feature in unittests. It can be used like this: + + "MyTestCase" >:: (bracket test_set_up test_fun test_tear_down) *) + +(** *) +val bracket : (unit -> 'a) -> ('a -> 'b) -> ('a -> 'c) -> unit -> 'c + +(** {5 Constructing Tests} *) + +(** The type of test function *) +type test_fun = unit -> unit + +(** The type of tests *) +type test = + TestCase of test_fun + | TestList of test list + | TestLabel of string * test + +(** Create a TestLabel for a test *) +val (>:) : string -> test -> test + +(** Create a TestLabel for a TestCase *) +val (>::) : string -> test_fun -> test + +(** Create a TestLabel for a TestList *) +val (>:::) : string -> test list -> test + +(** Some shorthands which allows easy test construction. + + Examples: + + - ["test1" >: TestCase((fun _ -> ()))] => + [TestLabel("test2", TestCase((fun _ -> ())))] + - ["test2" >:: (fun _ -> ())] => + [TestLabel("test2", TestCase((fun _ -> ())))] + + - ["test-suite" >::: ["test2" >:: (fun _ -> ());]] => + [TestLabel("test-suite", TestSuite([TestLabel("test2", TestCase((fun _ -> ())))]))] +*) + +(** [test_decorate g tst] Apply [g] to test function contains in [tst] tree. *) +val test_decorate : (test_fun -> test_fun) -> test -> test + +(** [test_filter paths tst] Filter test based on their path string representation. *) +val test_filter : string list -> test -> test option + +(** {5 Retrieve Information from Tests} *) + +(** Returns the number of available test cases *) +val test_case_count : test -> int + +(** Types which represent the path of a test *) +type node = ListItem of int | Label of string +type path = node list (** The path to the test (in reverse order). *) + +(** Make a string from a node *) +val string_of_node : node -> string + +(** Make a string from a path. The path will be reversed before it is + tranlated into a string *) +val string_of_path : path -> string + +(** Returns a list with paths of the test *) +val test_case_paths : test -> path list + +(** {5 Performing Tests} *) + +(** The possible results of a test *) +type test_result = + RSuccess of path + | RFailure of path * string + | RError of path * string + | RSkip of path * string + | RTodo of path * string + +(** Events which occur during a test run *) +type test_event = + EStart of path + | EEnd of path + | EResult of test_result + +(** Perform the test, allows you to build your own test runner *) +val perform_test : (test_event -> 'a) -> test -> test_result list + +(** A simple text based test runner. It prints out information + during the test. *) +val run_test_tt : ?verbose:bool -> test -> test_result list + +(** Main version of the text based test runner. It reads the supplied command + line arguments to set the verbose level and limit the number of test to run + *) +val run_test_tt_main : test -> test_result list diff --git a/commons/ocaml.ml b/commons/ocaml.ml new file mode 100644 index 0000000..ce65700 --- /dev/null +++ b/commons/ocaml.ml @@ -0,0 +1,498 @@ +(* + * Yoann Padioleau + * + * Copyright (C) 2009-2012 Facebook + * + * Most of the code in this file was inspired by code by Gazagnaire. + * Here is the original copyright: + * + * Copyright (c) 2009 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) +open Common + +(*****************************************************************************) +(* Purpose *) +(*****************************************************************************) +(* + * OCaml hacks to support reflection. + * + * OCaml does not support reflection, and it's a good thing: we love + * strong type-checking that forbids too clever hacks like 'eval', or + * run-time reflection; it's too much power for you, you will misuse + * it. At the same time it's sometimes useful. So at least we could make + * it possible to still reflect on the type definitions or values in + * OCaml source code. We can do it by processing ML source code and + * emitting ML source code containing under the form of regular ML + * value or functions meta-information about information in other + * source code files. It's a little bit a poor's man reflection mechanism, + * because it's more manual, but it's for the best. Metaprogramming had + * to be painful, because it is dangerous! + * + * Example: + * + * TODO + * + * In some sense we reimplement what is in the OCaml compiler, which + * contains the full AST of OCaml source code. But the OCaml compiler + * and its AST are too big, too scary for many tasks that would be satisfied + * by a restricted but simpler AST. + * + * Camlp4 is obviously also a solution to this problem, but it has a + * learning curve, and it's a slightly different world than the pure + * regular OCaml world. So this module, and ocamltarzan together can + * reduce the problem by taking the best of camlp4, while still + * avoiding it. + * + * + * + * The support is partial. We support only the OCaml constructions + * we found the most useful for programming stuff like + * stub generators. + * + * less? not all OCaml so call it miniml.ml ? or reflection.ml ? + * + * + * Notes: 2 worlds + * - the type level world, + * - the data level world + * + * Then there is whether the code is generated on the fly, or output somewhere + * to be compiled and linked again (so 2 steps process, more manual, but + * arguably less complicated magic) + * + * different level of (meta)programming: + * + * - programming in OCaml on OCaml values (classic) + * - programming in OCaml on Sexp.t value of value + * - programming in OCaml on Sexp.t value of type description + * - programming in OCaml on OCaml.v value of value + * - programming in OCaml on OCaml.t value of type description + * + * Depending on what you have to do, some levels are more suited than other. + * For instance to do a show, to pretty print value, then sexp is good, + * because really you just want to write code that handle 2 cases, + * atoms and list. That's really what pretty printing is all about. You + * could write a pretty printer for Ocaml.v, but it will need to handle + * 10 cases. Now if you want to write a code generator for python, or an ORM, + * then Ocaml.v is better than sexp, because in sexp you lost some valuable + * information (that you may have to reverse engineer, like whether + * a Sexp.List corresponds to a field, or a sum, or wether something is + * null or an empty list, or wether it's an int or float, etc). + * + * Another way to do (meta)programming is: + * - programming in Camlp4 on OCaml ast + * - writing camlmix code to generate code. + * + * notes: + * - sexp value or sexp of type description, not as precise, but easier to + * write really generic code that do not need to have more information + * about the sexp nodes (such as wether it's a field, a constuctor, etc) + * - miniml value or type, not as precise that the regular type, + * but more precise than sexp, and allow write some generic code. + * - ocaml value (not type as you cant program at type level), + * precise type checking, but can be tedious to write generic + * code like generic visitors or pickler/unpicklers + * + * This file is working with ocamltarzan/pa/pa_type.ml (and so indirectly + * it is working with camlp4). + * + * Note that can even generate sexp_of_x for miniML :) really + * reflexive tower here + * + * Note that even if this module helps a programmer to avoid + * using directly camlp4 to auto generate some code, it can + * not solve all the tasks. + * + * history: + * - Thought about it when wanting to do the ast_php.ml to be + * transformed into a .adsl declaration to be able to generate + * corresponding python classes using astgen.py. + * - Thought about a miniMLType and miniMLValue, and then realize + * that that was maybe what code in the ocaml-orm-sqlite + * was doing (type-of et value-of), except I wanted the + * ocamltarzan style of meta-programming instead of the camlp4 one. + * + * + * Alternatives: + * - camlp4 + * obviously camlp4 has access to the full AST of OCaml, but + * that is one pb, that's too much. We often want only to do + * analysis on the type + * - type-conv + * good, but force to use camlp4. Can use the generic sexplib + * and then work on the generated sexp, but as explained below, + * is will be on the value. + * - use lib-sexp (just the sexp library part, not the camlp4 support part) + * but not enough info. Even if usually + * can reverse engineer the sexp to rediscover the type, + * you will reverse engineer a value; what you want + * is the sexp representation of the type! not a value of this type. + * Also lib-sexp autogenerated code can be hard to understand, especially + * if the type definition is complex. A good side effect of ocaml.ml + * is that it provides an intermediate step :) So even if you + * could pretty print value from your def to sexp directly, you could + * also use transform your value into a Ocaml.v, then use + * the somehow more readable function that translate a v into a sexp, + * and same when wanting to read a value from a sexp, by using + * again Ocaml.v as an intermediate. It's nevertheless obviously + * less efficient. + * + * - zephyr, or thrift ? + * - F# ? + * - Lisp/Scheme ? + * - .Net interoperability + * + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* src: + * - orm-sqlite/value/value.ml + * (itself a fork of http://xenbits.xen.org/xapi/xen-api-libs.hg?file/7a17b2ab5cfc/rpc-light/rpc.ml) + * - orm-sqlite/type-of/type.ml + * + * update: Gazagnaire made a paper about that. + * + * modifications: + * - slightly renamed the types and rearrange order of constructors. Could + * have use nested modules to allow to reuse Int in different contexts, + * but I actually prefer to prefix the values with the V, so when debugging + * stuff, it's clearer that what you are looking are values, not types + * (even if the ocaml toplevel would prefix the value with a V. or T., + * but sexp would not) + * - Changed Int of int option + * - Introduced List, Apply, Poly + * - debugging support (using sexp :) ) + *) + +(* OCaml type definitions *) +type t = + | Unit + | Bool | Float | Char | String | Int + + | Tuple of t list + | Dict of (string * [`RW|`RO] * t) list + | Sum of (string * t list) list + + | Var of string + | Poly of string + | Arrow of t * t + + | Apply of string * t + + (* special cases of Apply *) + | Option of t + | List of t + + (* todo? split in another type, because here it's the left part, + * whereas before is the right part of a type definition. Also + * have not the polymorphic args to some defs like ('a, 'b) Hashbtbl + * | Rec of string * t + * | Ext of string * t + * + * | Enum of t (* ??? *) + *) + + | TTODO of string + (* with tarzan *) + +(* OCaml values (a restricted form of expressions) *) +type v = + | VUnit + | VBool of bool | VFloat of float | VInt of int (* was int64 *) + | VChar of char | VString of string + + | VTuple of v list + | VDict of (string * v) list + | VSum of string * v list + + | VVar of (string * int64) + | VArrow of string + + (* special cases *) + | VNone | VSome of v + | VList of v list + | VRef of v + +(* + | VEnum of v list (* ??? *) + | VRec of (string * int64) * v + | VExt of (string * int64) * v +*) + + | VTODO of string + (* with tarzan *) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +(* the generated code can use that if he wants *) +let (_htype: (string, t) Hashtbl.t) = + Hashtbl.create 101 +let (add_new_type: string -> t -> unit) = fun s t -> + Hashtbl.add _htype s t +let (get_type: string -> t) = fun s -> + Hashtbl.find _htype s + + + +(* for generated code that want to transform and in and out of a v or t *) +let vof_unit () = + VUnit +let vof_int x = + VInt ((*Int64.of_int*) x) +let vof_float x = + VFloat ((*Int64.of_int*) x) +let vof_string x = + VString x +let vof_bool b = + VBool b +let vof_list ofa x = + VList (List.map ofa x) +let vof_option ofa x = + match x with + | None -> VNone + | Some x -> VSome (ofa x) +let vof_ref ofa x = + match x with + | {contents = x } -> VRef (ofa x) +let vof_either _of_a _of_b = + function + | Left v1 -> let v1 = _of_a v1 in VSum (("Left", [ v1 ])) + | Right v1 -> let v1 = _of_b v1 in VSum (("Right", [ v1 ])) + +let vof_either3 _of_a _of_b _of_c = + function + | Left3 v1 -> let v1 = _of_a v1 in VSum (("Left3", [ v1 ])) + | Middle3 v1 -> let v1 = _of_b v1 in VSum (("Middle3", [ v1 ])) + | Right3 v1 -> let v1 = _of_c v1 in VSum (("Right3", [ v1 ])) + + + +let int_ofv = function + | VInt x -> x + | _ -> failwith "ofv: was expecting a VInt" +let float_ofv = function + | VFloat x -> x + | _ -> failwith "ofv: was expecting a VFloat" +let string_ofv = function + | VString x -> x + | _ -> failwith "ofv: was expecting a VString" +let unit_ofv = function + | VUnit -> () + | _ -> failwith "ofv: was expecting a VUnit" + +let list_ofv a__of_sexp sexp = match sexp with + | VList lst -> + let rev_lst = List.rev_map a__of_sexp lst in + List.rev rev_lst + | _ -> failwith "list_ofv: VLlist needed" + +let option_ofv a__of_sexp sexp = match sexp with + | VNone -> None + | VSome x -> Some (a__of_sexp x) + | _ -> failwith "option_ofv: VNone or VSome needed" + +(*****************************************************************************) +(* Format pretty printers *) +(*****************************************************************************) +let add_sep xs = + xs +> List.map (fun x -> Right x) +> Common2.join_gen (Left ()) + +(* + * OCaml value pretty printer. A similar functionnality is provided by + * the OCaml toplevel interpreter ('/usr/bin/ocaml') but + * sometimes it is useful to print values from a regular command + * line program. You don't always want to run the ocaml interpreter (or + * customized interpreter built by ocamlmktop), and type an expression + * in to get the printed value. + * + * The v_of_xxx generated code by ocamltarzan is + * the first part to make this possible. The function below + * is the second part. + * + * The '@[', '@,', etc are Format printf tags. See the doc of the Format + * module in the OCaml manual to understand their meaning. Mainly, + * @[ and @] open and close a pretty print box, and '@ ' and '@,' + * are to give breaking hints to the pretty printer. + * + * The output can be copy pasted in ML code directly, which can be + * useful when you want to pattern match over complex ocaml value. + *) + +let string_of_v v = + Common2.format_to_string (fun () -> + let ppf = Format.printf in + let rec aux v = + match v with + | VUnit -> ppf "()" + | VBool v1 -> + if v1 + then ppf "true" + else ppf "false" + | VFloat v1 -> ppf "%f" v1 + | VChar v1 -> ppf "'%c'" v1 + | VString v1 -> ppf "\"%s\"" v1 + | VInt i -> ppf "%d" i + | VTuple xs -> + ppf "(@["; + xs +> add_sep +> List.iter (function + | Left _ -> ppf ",@ "; + | Right v -> aux v + ); + ppf "@])"; + | VDict xs -> + ppf "{@["; + xs +> List.iter (fun (s, v) -> + (* less: could open a box there too? *) + ppf "@,%s=" s; + aux v; + ppf ";@ "; + ); + ppf "@]}"; + + | VSum ((s, xs)) -> + (match xs with + | [] -> ppf "%s" s + | y::ys -> + ppf "@[%s(@," s; + xs +> add_sep +> List.iter (function + | Left _ -> ppf ",@ "; + | Right v -> aux v + ); + ppf "@])"; + ) + + | VVar (s, i64) -> ppf "%s_%d" s (Int64.to_int i64) + | VArrow v1 -> failwith "Arrow TODO" + | VNone -> ppf "None"; + | VSome v -> ppf "Some(@["; aux v; ppf "@])"; + | VRef v -> ppf "Ref(@["; aux v; ppf "@])"; + | VList xs -> + ppf "[@["; + xs +> add_sep +> List.iter (function + | Left _ -> ppf ";@ "; + | Right v -> aux v + ); + ppf "@]]"; + | VTODO v1 -> ppf "VTODO" + in + aux v + ) + +(*****************************************************************************) +(* Mapper Visitor *) +(*****************************************************************************) + +let map_of_unit x = () +let map_of_bool x = x +let map_of_float x = x +let map_of_char x = x +let map_of_string (s:string) = s + +let map_of_ref aref x = x (* dont go into ref *) +let map_of_option v_of_a v = + match v with + | None -> None + | Some x -> Some (v_of_a x) +let map_of_list of_a xs = + List.map of_a xs +let map_of_int x = x +let map_of_int64 x = x + +let map_of_either _of_a _of_b = + function + | Left v1 -> let v1 = _of_a v1 in Left ((v1)) + | Right v1 -> let v1 = _of_b v1 in Right ((v1)) + +let map_of_either3 _of_a _of_b _of_c = + function + | Left3 v1 -> let v1 = _of_a v1 in Left3 ((v1)) + | Middle3 v1 -> let v1 = _of_b v1 in Middle3 ((v1)) + | Right3 v1 -> let v1 = _of_c v1 in Right3 ((v1)) + + +(* this is subtle ... *) +let rec (map_v: f:( k:(v -> v) -> v -> v) -> v -> v) = + fun ~f x -> + + let rec map_v v = + (* generated by ocamltarzan with: camlp4o -o /tmp/yyy.ml -I pa/ pa_type_conv.cmo pa_map.cmo pr_o.cmo /tmp/xxx.ml *) + let rec k x = + match x with + | VUnit -> VUnit + | VBool v1 -> let v1 = map_of_bool v1 in VBool ((v1)) + | VFloat v1 -> let v1 = map_of_float v1 in VFloat ((v1)) + | VChar v1 -> let v1 = map_of_char v1 in VChar ((v1)) + | VString v1 -> let v1 = map_of_string v1 in VString ((v1)) + | VInt v1 -> let v1 = map_of_int v1 in VInt ((v1)) + | VTuple v1 -> let v1 = map_of_list map_v v1 in VTuple ((v1)) + | VDict v1 -> + let v1 = + map_of_list + (fun (v1, v2) -> + let v1 = map_of_string v1 and v2 = map_v v2 in (v1, v2)) + v1 + in VDict ((v1)) + | VSum ((v1, v2)) -> + let v1 = map_of_string v1 + and v2 = map_of_list map_v v2 + in VSum ((v1, v2)) + | VVar v1 -> + let v1 = + (match v1 with + | (v1, v2) -> + let v1 = map_of_string v1 and v2 = map_of_int64 v2 in (v1, v2)) + in VVar ((v1)) + | VArrow v1 -> let v1 = map_of_string v1 in VArrow ((v1)) + | VNone -> VNone + | VSome v1 -> let v1 = map_v v1 in VSome ((v1)) + | VRef v1 -> let v1 = map_v v1 in VRef ((v1)) + | VList v1 -> let v1 = map_of_list map_v v1 in VList ((v1)) + | VTODO v1 -> let v1 = map_of_string v1 in VTODO ((v1)) + in + f ~k v + in + map_v x + +(*****************************************************************************) +(* Iterator Visitor *) +(*****************************************************************************) + +let v_unit x = () +let v_bool x = () +let v_int x = () +let v_string (s:string) = () +let v_ref aref x = () (* dont go into ref *) +let v_option v_of_a v = + match v with + | None -> () + | Some x -> v_of_a x +let v_list of_a xs = + List.iter of_a xs + +let v_either of_a of_b x = + match x with + | Left a -> of_a a + | Right b -> of_b b + +let v_either3 of_a of_b of_c x = + match x with + | Left3 a -> of_a a + | Middle3 b -> of_b b + | Right3 c -> of_c c diff --git a/commons/ocaml.mli b/commons/ocaml.mli new file mode 100644 index 0000000..9b26501 --- /dev/null +++ b/commons/ocaml.mli @@ -0,0 +1,130 @@ + +(* + * OCaml hacks to support reflection (works with ocamltarzan). + * + * See also sexp.ml, json.ml, and xml.ml for other "reflective" techniques. + *) + +(* OCaml core type definitions (no objects, no modules) *) +type t = + | Unit + | Bool | Float | Char | String | Int + + | Tuple of t list + | Dict of (string * [`RW|`RO] * t) list (* aka record *) + | Sum of (string * t list) list (* aka variants *) + + | Var of string + | Poly of string + | Arrow of t * t + + | Apply of string * t + + (* special cases of Apply *) + | Option of t + | List of t + + | TTODO of string + +val add_new_type: string -> t -> unit +val get_type: string -> t + +(* OCaml values (a restricted form of expressions) *) +type v = + | VUnit + | VBool of bool | VFloat of float | VInt of int + | VChar of char | VString of string + + | VTuple of v list + | VDict of (string * v) list + | VSum of string * v list + + | VVar of (string * int64) + | VArrow of string + + (* special cases *) + | VNone | VSome of v + | VList of v list + | VRef of v + + | VTODO of string + +(* building blocks, used by code generated using ocamltarzan *) +val vof_unit : unit -> v +val vof_bool : bool -> v +val vof_int : int -> v +val vof_float : float -> v +val vof_string : string -> v +val vof_list : ('a -> v) -> 'a list -> v +val vof_option : ('a -> v) -> 'a option -> v +val vof_ref : ('a -> v) -> 'a ref -> v +val vof_either : ('a -> v) -> ('b -> v) -> ('a, 'b) Common.either -> v +val vof_either3 : ('a -> v) -> ('b -> v) -> ('c -> v) -> + ('a, 'b, 'c) Common.either3 -> v + +val int_ofv: v -> int +val float_ofv: v -> float +val unit_ofv: v -> unit +val string_ofv: v -> string +val list_ofv: (v -> 'a) -> v -> 'a list +val option_ofv: (v -> 'a) -> v -> 'a option + +(* regular pretty printer (not via sexp, but using Format) *) +val string_of_v: v -> string + +(* sexp converters *) +(* +val sexp_of_t: t -> Sexp.t +val t_of_sexp: Sexp.t -> t +val sexp_of_v: v -> Sexp.t +val v_of_sexp: Sexp.t -> v +val string_sexp_of_t: t -> string +val t_of_string_sexp: string -> t +val string_sexp_of_v: v -> string +val v_of_string_sexp: string -> v +*) + +(* json converters *) +(* +val v_of_json: Json_type.json_type -> v +val json_of_v: v -> Json_type.json_type +val save_json: Common.filename -> Json_type.json_type -> unit +val load_json: Common.filename -> Json_type.json_type +*) + +(* mapper/visitor *) +val map_v: + f:( k:(v -> v) -> v -> v) -> + v -> + v + +(* other building blocks, used by code generated using ocamltarzan *) +val map_of_unit: unit -> unit +val map_of_bool: bool -> bool +val map_of_int: int -> int +val map_of_float: float -> float +val map_of_char: char -> char +val map_of_string: string -> string +val map_of_ref: 'a -> 'b -> 'b +val map_of_option: ('a -> 'b) -> 'a option -> 'b option +val map_of_list: ('a -> 'a) -> 'a list -> 'a list +val map_of_either: + ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) Common.either -> ('b, 'd) Common.either +val map_of_either3: + ('a -> 'b) -> ('c -> 'd) -> ('e -> 'f) -> + ('a, 'c, 'e) Common.either3 -> ('b, 'd, 'f) Common.either3 + +(* pure visitor building blocks, used by code generated using ocamltarzan *) +val v_unit: unit -> unit +val v_bool: bool -> unit +val v_int: int -> unit +val v_string: string -> unit +val v_option: ('a -> unit) -> 'a option -> unit +val v_list: ('a -> unit) -> 'a list -> unit +val v_ref: ('a -> unit) -> 'a ref -> unit +val v_either: + ('a -> unit) -> ('b -> unit) -> + ('a, 'b) Common.either -> unit +val v_either3: + ('a -> unit) -> ('b -> unit) -> ('c -> unit) -> + ('a, 'b, 'c) Common.either3 -> unit diff --git a/commons/readme.txt b/commons/readme.txt new file mode 100644 index 0000000..1df2997 --- /dev/null +++ b/commons/readme.txt @@ -0,0 +1,29 @@ +This directory builds a common.cma library and also optionally +multiple commons_xxx.cma small libraries. The reason not to just build +a single one is that some functionnalities require external libraries +(like Berkeley DB, MPI, etc) or special version of OCaml (like for the +backtrace support) and I don't want to penalize the user by forcing +him to install all those libs before being able to use some of my +common helper functions. So, common.ml and other files offer +convenient helpers that do not require to install anything. In some +cases I have directly included the code of those external libs when +there are simple such as for ANSITerminal in ocamlextra/, and for +dumper.ml I have even be further by inlining its code in common.ml so +one can just do a open Common and have everything. Then if the user +wants to, he can also leverage the other commons_xxx libraries by +explicitely building them after he has installed the necessary +external files. + +For many configurable things we can use some flags in ml files, +and have some -xxx command line argument to set them or not, +but for other things flags are not enough as they will not remove +the header and linker dependencies in Makefiles. A solution is +to use cpp and pre-process many files that have such configuration +issue. Another solution is to centralize all the cpp issue in one +file, features.ml.in, that acts as a generic wrapper for other +librairies and depending on the configuration actually call +the external library or provide a fake empty services indicating +that the service is not present. +So you should have a ../configure that call cpp on features.ml.in +to set those linking-related configuration settings. + diff --git a/commons/set_.ml b/commons/set_.ml new file mode 100644 index 0000000..98c7b21 --- /dev/null +++ b/commons/set_.ml @@ -0,0 +1,302 @@ +(*pad: taken from set.ml from stdlib ocaml, functor sux: module Make(Ord: OrderedType) = *) +(* with some addons such as from list *) + + +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* set.ml 1.18.4.1 2004/11/03 21:19:49 doligez Exp *) + +(* Sets over ordered types *) + +(* pad: + type elt = Ord.t + type t = Empty | Node of t * elt * t * int + and subst all Ord.compare with just compare +*) + type 'elt t = Empty | Node of 'elt t * 'elt * 'elt 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 v and right son r. + We must have all elements of l < v < all elements of r. + l and r must be balanced and | height l - height r | <= 2. + Inline expansion of height for better speed. *) + + let create l v 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, v, 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 and | height l - height r | <= 3. + Inline expansion of create for better speed in the most frequent case + where no rebalancing is required. *) + + let bal l v 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 v r) + else begin + match lr with + Empty -> invalid_arg "Set.bal" + | Node(lrl, lrv, lrr, _)-> + create (create ll lv lrl) lrv (create lrr v 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 v rl) rv rr + else begin + match rl with + Empty -> invalid_arg "Set.bal" + | Node(rll, rlv, rlr, _) -> + create (create l v rll) rlv (create rlr rv rr) + end + end else + Node(l, v, r, (if hl >= hr then hl + 1 else hr + 1)) + + (* Insertion of one element *) + + let rec add x = function + Empty -> Node(Empty, x, Empty, 1) + | Node(l, v, r, _) as t -> + let c = 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) + + (* Same as create and bal, but no assumptions are made on the + relative heights of l and r. *) + + let rec join l v r = + match (l, r) with + (Empty, _) -> add v r + | (_, Empty) -> add v l + | (Node(ll, lv, lr, lh), Node(rl, rv, rr, rh)) -> + if lh > rh + 2 then bal ll lv (join lr v r) else + if rh > lh + 2 then bal (join l v rl) rv rr else + create l v r + + (* Smallest and greatest element of a set *) + + 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 + + (* Remove the smallest element of the given set *) + + let rec remove_min_elt = function + Empty -> invalid_arg "Set.remove_min_elt" + | Node(Empty, v, r, _) -> r + | Node(l, v, r, _) -> bal (remove_min_elt l) v r + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + Assume | height l - height r | <= 2. *) + + let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> bal t1 (min_elt t2) (remove_min_elt t2) + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + No assumption on the heights of l and r. *) + + let concat t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> join t1 (min_elt t2) (remove_min_elt t2) + + (* Splitting. split x s returns a triple (l, present, r) where + - l is the set of elements of s that are < x + - r is the set of elements of s that are > x + - present is false if s contains no element equal to x, + or true if s contains an element equal to x. *) + + let rec split x = function + Empty -> + (Empty, false, Empty) + | Node(l, v, r, _) -> + let c = compare x v in + if c = 0 then (l, true, r) + else if c < 0 then + let (ll, pres, rl) = split x l in (ll, pres, join rl v r) + else + let (lr, pres, rr) = split x r in (join l v lr, pres, 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 = compare x v in + c = 0 || mem x (if c < 0 then l else r) + + let singleton x = Node(Empty, x, Empty, 1) + + let rec remove x = function + Empty -> Empty + | Node(l, v, r, _) -> + let c = 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, false, r2) -> + concat (inter l1 l2) (inter r1 r2) + | (l2, true, 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, false, r2) -> + join (diff l1 l2) v1 (diff r1 r2) + | (l2, true, 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 = 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 = Pervasives.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 choose = min_elt + +(* pad: *) +let (of_list: 'a list -> 'a t) = fun xs -> + List.fold_left (fun a e -> add e a) empty xs + + + diff --git a/commons/set_.mli b/commons/set_.mli new file mode 100644 index 0000000..7b4aa91 --- /dev/null +++ b/commons/set_.mli @@ -0,0 +1,161 @@ +(*pad: taken from set.ml from stdlib ocaml, functor sux: module Make(Ord: OrderedType) = *) +(* with some addons such as from list *) +(***********************************************************************) +(* *) +(* 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. *) +(* *) +(***********************************************************************) + +(* set.mli 1.32 2004/04/23 10:01:54 xleroy 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. +*) +(* pad: +module type OrderedType = + sig + type t + (** The type of the set elements. *) + val compare : t -> 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 elt *) + (** The type of the set elements. *) + + type 'elt t + (** The type of sets. *) + + val empty: 'elt t + (** The empty set. *) + + val is_empty: 'elt t -> bool + (** Test whether a set is empty or not. *) + + val mem: 'elt -> 'elt t -> bool + (** [mem x s] tests whether [x] belongs to the set [s]. *) + + val add: 'elt -> 'elt t -> 'elt 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: 'elt -> 'elt t + (** [singleton x] returns the one-element set containing only [x]. *) + + val remove: 'elt -> 'elt t -> 'elt 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: 'elt t -> 'elt t -> 'elt t + (** Set union. *) + + val inter: 'elt t -> 'elt t -> 'elt t + (** Set intersection. *) + + (** Set difference. *) + val diff: 'elt t -> 'elt t -> 'elt t + + val compare: 'elt t -> 'elt t -> int + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + val equal: 'elt t -> 'elt t -> bool + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + + val subset: 'elt t -> 'elt t -> bool + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) + + val iter: ('elt -> unit) -> 'elt t -> unit + (** [iter f s] applies [f] in turn to all elements of [s]. + The elements of [s] are presented to [f] in increasing order + with respect to the ordering over the type of the elements. *) + + val fold: ('elt -> 'a -> 'a) -> 'elt t -> 'a -> 'a + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s], in increasing order. *) + + val for_all: ('elt -> bool) -> 'elt t -> bool + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + val exists: ('elt -> bool) -> 'elt t -> bool + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + val filter: ('elt -> bool) -> 'elt t -> 'elt t + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + + val partition: ('elt -> bool) -> 'elt t -> 'elt t * 'elt 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: 'elt t -> int + (** Return the number of elements of a set. *) + + val elements: 'elt t -> '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: 'elt t -> '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: 'elt t -> 'elt + (** Same as {!Set.S.min_elt}, but returns the largest element of the + given set. *) + + val choose: 'elt t -> '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. *) + + val split: 'elt -> 'elt t -> 'elt t * bool * 'elt t + (** [split x s] returns a triple [(l, present, r)], where + [l] is the set of elements of [s] that are + strictly less than [x]; + [r] is the set of elements of [s] that are + strictly greater than [x]; + [present] is [false] if [s] contains no element equal to [x], + or [true] if [s] contains an element equal to [x]. *) + + val of_list: 'elt list -> 'elt t +(* + end +(** Output signature of the functor {!Set.Make}. *) + +module Make (Ord : OrderedType) : S with type elt = Ord.t +(** Functor building an implementation of the set structure + given a totally ordered type. *) +*) diff --git a/commons_core/.depend b/commons_core/.depend new file mode 100644 index 0000000..1ff21d7 --- /dev/null +++ b/commons_core/.depend @@ -0,0 +1,8 @@ +ANSITerminal.cmo : ANSITerminal.cmi +ANSITerminal.cmx : ANSITerminal.cmi +ANSITerminal.cmi : +console.cmo : ../commons/common2.cmi ../commons/common.cmi ANSITerminal.cmi \ + console.cmi +console.cmx : ../commons/common2.cmx ../commons/common.cmx ANSITerminal.cmx \ + console.cmi +console.cmi : diff --git a/commons_core/ANSITerminal.ml b/commons_core/ANSITerminal.ml new file mode 100644 index 0000000..8fcfa4a --- /dev/null +++ b/commons_core/ANSITerminal.ml @@ -0,0 +1,219 @@ +(* File: ANSITerminal.ml + Allow colors, cursor movements, erasing,... under Unix and DOS shells. + ********************************************************************* + + Copyright 2004 by Troestler Christophe + Christophe.Troestler(at)umh.ac.be + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public License + version 2.1 as published by the Free Software Foundation, with the + special exception on linking described in file LICENSE. + + This library 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 file + LICENSE for more details. +*) +(** See the file ctlseqs.html (unix) + and (for DOS) http://www.ka.net/jmenees/Dos/Ansi.htm + *) + + +open Printf + +(* Erasing *) + +type loc = Above | Below | Screen + +let erase = function + | Above -> print_string "\027[1J" + | Below -> print_string "\027[0J" + | Screen -> print_string "\027[2J" + + +(* Cursor *) + +let set_cursor x y = + if x <= 0 then (if y > 0 then printf "\027[%id" y) + else (* x > 0 *) if y <= 0 then printf "\027[%iG" x + else printf "\027[%i;%iH" y x + +let move_cursor x y = + if x > 0 then printf "\027[%iC" x + else if x < 0 then printf "\027[%iD" (-x); + if y > 0 then printf "\027[%iB" y + else if y < 0 then printf "\027[%iA" (-y) + +let save_cursor () = print_string "\027[s" +let restore_cursor () = print_string "\027[u" + +(* Scrolling *) + +let scroll lines = + if lines > 0 then printf "\027[%iS" lines + else if lines < 0 then printf "\027[%iT" (- lines) + +(* Colors *) + +let autoreset = ref true + +let set_autoreset b = autoreset := b + + +type color = + Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Default + +type style = + | Reset | Bold | Underlined | Blink | Inverse | Hidden + | Foreground of color + | Background of color + +let black = Foreground Black +let red = Foreground Red +let green = Foreground Green +let yellow = Foreground Yellow +let blue = Foreground Blue +let magenta = Foreground Magenta +let cyan = Foreground Cyan +let white = Foreground White +let default = Foreground Default + +let on_black = Background Black +let on_red = Background Red +let on_green = Background Green +let on_yellow = Background Yellow +let on_blue = Background Blue +let on_magenta = Background Magenta +let on_cyan = Background Cyan +let on_white = Background White +let on_default = Background Default + +let style_to_string = function + | Reset -> "0" + | Bold -> "1" + | Underlined -> "4" + | Blink -> "5" + | Inverse -> "7" + | Hidden -> "8" + | Foreground Black -> "30" + | Foreground Red -> "31" + | Foreground Green -> "32" + | Foreground Yellow -> "33" + | Foreground Blue -> "34" + | Foreground Magenta -> "35" + | Foreground Cyan -> "36" + | Foreground White -> "37" + | Foreground Default -> "39" + | Background Black -> "40" + | Background Red -> "41" + | Background Green -> "42" + | Background Yellow -> "43" + | Background Blue -> "44" + | Background Magenta -> "45" + | Background Cyan -> "46" + | Background White -> "47" + | Background Default -> "49" + + +let print_string style txt = + print_string "\027["; + let s = String.concat ";" (List.map style_to_string style) in + print_string s; + print_string "m"; + print_string txt; + if !autoreset then print_string "\027[0m" + + +let printf style = kprintf (print_string style) + + + +(* On DOS & windows, to enable the ANSI sequences, ANSI.SYS should be + loaded in C:\CONFIG.SYS with a line of the type + + DEVICE = C:\DOS\ANSI.SYS + DEVICEHIGH=C:\WINDOWS\COMMAND\ANSI.SYS + + This routine checks whether the line is present and, if not, it + inserts it and tells the user to reboot. + + On WINNT, one will create a ANSI.NT in the user dir and a + command.com link on the desktop (with Configfilename = our ANSI.NT) + and tell the user to use it. + + REM: that does NOT work under winxp because OCaml programs are not + considered to run in DOS mode only... + + http://support.microsoft.com/default.aspx?scid=kb;en-us;816179 + http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dllproc/base/console_functions.asp +*) + + +(* let is_readable file = *) +(* try close_in(open_in file); true *) +(* with Sys_error _ -> false *) + +(* let config_sys = "C:\\CONFIG.SYS" *) +(* exception OK *) + +(* let win9x () = *) +(* (\* Locate ANSI.SYS *\) *) +(* let ansi_sys = List.find is_readable [ *) +(* "C:\\DOS\\ANSI.SYS"; *) +(* "C:\\WINDOWS\\COMMAND\\ANSI.SYS"; ] in *) +(* (\* Parse CONFIG.SYS to see wether it has the right line *\) *) +(* try *) +(* let re = Str.regexp_case_fold *) +(* ("^DEVICE\\(HIGH\\)?[ \t]*=[ \t]*" ^ ansi_sys ^ "[ \t]*$") in *) +(* let fh = open_in config_sys in *) +(* begin try *) +(* while true do *) +(* if Str.string_match re (input_line fh) 0 then raise OK *) +(* done *) +(* with *) +(* | End_of_file -> *) +(* (\* Correct line not found: add it *\) *) +(* close_in fh; *) +(* raise(Sys_error "win9x") *) +(* | OK -> close_in fh (\* Correct line found, keep going *\) *) +(* end *) +(* with Sys_error _ -> *) +(* (\* config_sys not does not exists or does not contain the right line. *\) *) +(* let fh = open_out_gen [Open_wronly; Open_append; Open_creat; Open_text] *) +(* 0x777 config_sys in *) +(* output_string fh ("DEVICEHIGH=" ^ ansi_sys ^ "\n"); *) +(* close_out fh; *) +(* prerr_endline "Please restart your computer and rerun the program."; *) +(* exit 1 *) + + + +(* let winnt home = *) +(* (\* Locate ANSI.SYS *\) *) +(* let system = *) +(* try Sys.getenv "SystemRoot" *) +(* with Not_found -> "C:\\WINDOWS" in *) +(* let ansi_sys = *) +(* List.find is_readable (List.map (fun s -> Filename.concat system s) *) +(* [ "SYSTEM32\\ANSI.SYS"; ]) in *) +(* (\* Create an ANSI.SYS file in the user dir *\) *) +(* let ansi_nt = Filename.concat home "ANSI.NT" in *) +(* let fh = open_out ansi_nt in *) +(* output_string fh "dosonly\ndevice="; *) +(* output_string fh ansi_sys; *) +(* output_string fh "\ndevice=%SystemRoot%\\system32\\himem.sys *) +(* files=40 *) +(* dos=high, umb *) +(* " ; *) +(* close_out fh; *) +(* (\* Make a command.com link on the desktop *\) *) +(* let fh = open_out (Filename.concat home "command.lnk") in *) +(* close_out fh *) + + +(* let () = *) +(* if Sys.os_type = "Win32" then begin *) +(* try winnt(Sys.getenv "USERPROFILE") (\* WinNT, Win2000, WinXP *\) *) +(* with Not_found -> win9x() (\* Win9x *\) *) +(* end *) diff --git a/commons_core/ANSITerminal.mli b/commons_core/ANSITerminal.mli new file mode 100644 index 0000000..dd203b3 --- /dev/null +++ b/commons_core/ANSITerminal.mli @@ -0,0 +1,107 @@ +(* File: ANSITerminal.mli + + Copyright 2004 Troestler Christophe + Christophe.Troestler(at)umh.ac.be + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public License + version 2.1 as published by the Free Software Foundation, with the + special exception on linking described in file LICENSE. + + This library 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 file + LICENSE for more details. +*) +(** This module offers basic control of ANSI compliant terminals. + + @author Christophe Troestler + @version 0.3 +*) + +(** {2 Color} *) + +type color = + | Black | Red | Green | Yellow | Blue | Magenta | Cyan | White + | Default (** Default color of the terminal *) + +(** Various styles for the text. [Blink] and [Hidden] may not work on + every terminal. *) +type style = + | Reset + | Bold | Underlined | Blink | Inverse | Hidden + | Foreground of color + | Background of color + +val black : style (** Shortcut for [Foreground Black] *) +val red : style (** Shortcut for [Foreground Red] *) +val green : style (** Shortcut for [Foreground Green] *) +val yellow : style (** Shortcut for [Foreground Yellow] *) +val blue : style (** Shortcut for [Foreground Blue] *) +val magenta : style (** Shortcut for [Foreground Magenta] *) +val cyan : style (** Shortcut for [Foreground Cyan] *) +val white : style (** Shortcut for [Foreground White] *) +val default : style (** Shortcut for [Foreground Default] *) + +val on_black : style (** Shortcut for [Background Black] *) +val on_red : style (** Shortcut for [Background Red] *) +val on_green : style (** Shortcut for [Background Green] *) +val on_yellow : style (** Shortcut for [Background Yellow] *) +val on_blue : style (** Shortcut for [Background Blue] *) +val on_magenta : style (** Shortcut for [Background Magenta] *) +val on_cyan : style (** Shortcut for [Background Cyan] *) +val on_white : style (** Shortcut for [Background White] *) +val on_default : style (** Shortcut for [Background Default] *) + +val set_autoreset : bool -> unit + (** Turns the autoreset feature on and off. It defaults to on. *) + +val print_string : style list -> string -> unit + (** [print_string attr txt] prints the string [txt] with the + attibutes [attr]. After printing, the attributes are + automatically reseted to the defaults, unless autoreset is turned + off. *) + +val printf : style list -> ('a, unit, string, unit) format4 -> 'a + (** [printf attr format arg1 ... argN] prints the arguments + [arg1],...,[argN] according to [format] with the attibutes [attr]. + After printing, the attributes are automatically reseted to the + defaults, unless autoreset is turned off. *) + + +(** {2 Erasing} *) + +type loc = Above | Below | Screen + +val erase : loc -> unit + (** [erase Above] erases everything before the position of the cursor. + [erase Below] erases everything after the position of the cursor. + [erase Screen] erases the whole screen. + *) + + +(** {2 Cursor} *) + +val set_cursor : int -> int -> unit + (** [set_cursor x y] puts the cursor at position [(x,y)], [x] + indicating the column (the leftmost one being 1) and [y] being the + line (the topmost one being 1). If [x <= 0], the [x] coordinate + is unchanged; if [y <= 0], the [y] coordinate is unchanged. *) + +val move_cursor : int -> int -> unit + (** [move_cursor x y] moves the cursor by [x] columns (to the right + if [x > 0], to the left if [x < 0]) and by [y] lines (downwards if + [y > 0] and upwards if [y < 0]). *) + +val save_cursor : unit -> unit + (** [save_cursor()] saves the current position of the cursor. *) +val restore_cursor : unit -> unit + (** [restore_cursor()] replaces the cursor to the position saved + with [save_cursor()]. *) + + +(** {2 Scrolling} *) + +val scroll : int -> unit + (** [scroll n] scrolls the terminal by [n] lines, up (creating new + lines at the bottom) if [n > 0] and down if [n < 0]. *) diff --git a/commons_core/META b/commons_core/META new file mode 100644 index 0000000..c66be8e --- /dev/null +++ b/commons_core/META @@ -0,0 +1,4 @@ +description = "Generic functions from pfff, yet another extended stdlib" +requires = "unix num" +archive(byte) = "commons_core.cma" +archive(native) = "commons_core.cmxa" diff --git a/commons_core/Makefile b/commons_core/Makefile new file mode 100644 index 0000000..0ffdbff --- /dev/null +++ b/commons_core/Makefile @@ -0,0 +1,19 @@ +############################################################################## +# Variables +############################################################################## + +-include ../Makefile.config + +INCLUDEDIRS=../commons + +LIBNAME=commons_core + +SRC=ANSITerminal.ml console.ml + + +EXPORTSRC=$(SRC:%.ml=%.mli) + +OCAMLMKLIB=ocamlc -a +OCAMLMKLIBOPT=ocamlopt -a + +-include ../commons/Makefile.common diff --git a/commons_core/console.ml b/commons_core/console.ml new file mode 100644 index 0000000..2bbd3f5 --- /dev/null +++ b/commons_core/console.ml @@ -0,0 +1,93 @@ +(* used to be called common_extra.ml *) + +(* + * How to use it ? ex in LFS: + * Console.progress (w.prop_iprop#length) (fun k -> + * w.prop_iprop#iter (fun (p, ip) -> + * k (); + * ... + * )); + * + * todo: Unix.isatty, and the spinner trick of jason \ | / - + *) + +let execute_and_show_progress ~show len f = + let _count = ref 0 in + (* kind of continuation passed to f *) + let continue_pourcentage () = + incr _count; + ANSITerminal.set_cursor 1 (-1); + ANSITerminal.printf [] "%d / %d" !_count len; flush stdout; + in + let nothing () = () in + + (* ANSITerminal.printf [] "0 / %d" len; flush stdout; *) + (if !Common2._batch_mode || not show + then f nothing + else f continue_pourcentage + ); + Common.pr2 "" + + +let execute_and_show_progress2 ?(show=true) len f = + let _count = ref 0 in + (* kind of continuation passed to f *) + let continue_pourcentage () = + incr _count; + ANSITerminal.set_cursor 1 (-1); + ANSITerminal.printf [] "%d / %d" !_count len; flush stdout; + in + let nothing () = () in + + (* ANSITerminal.printf [] "0 / %d" len; flush stdout; *) + if !Common2._batch_mode || not show + then f nothing + else f continue_pourcentage + +let with_progress_list_metter ?show fk xs = + let len = List.length xs in + execute_and_show_progress2 ?show len + (fun k -> fk k xs) + +let progress ?show fk xs = + with_progress_list_metter ?show fk xs + + +(* +(* old code +let ansi_terminal = ref true *) + +let (_execute_and_show_progress_func: + (show:bool -> + int (* length *) -> ((unit -> unit) -> 'a) -> 'a) ref) + = ref + (fun ~show a b -> + failwith "no execute yet, have you included common_extra.cmo?" + ) + +let execute_and_show_progress ?(show=true) len f = + !_execute_and_show_progress_func ~show len f + +(* don't forget to call Common_extra.set_link () *) + +val _execute_and_show_progress_func : + (show:bool -> int (* length *) -> ((unit -> unit) -> unit) -> unit) + ref +val execute_and_show_progress : + ?show:bool -> int (* length *) -> ((unit -> unit) -> unit) -> unit + +let set_link () = + Common2._execute_and_show_progress_func := execute_and_show_progress + + +let _init_execute = + set_link () + + +*) + +(* now in common_extra.ml: + * let execute_and_show_progress len f = ... + *) + + diff --git a/commons_core/console.mli b/commons_core/console.mli new file mode 100644 index 0000000..36c1452 --- /dev/null +++ b/commons_core/console.mli @@ -0,0 +1,14 @@ +(* to be used as in + * xs +> Common_extra.progress (fun k -> List.iter (fun x -> k(); ...)) + *) +val progress: + ?show:bool -> ((unit -> unit) -> 'a list -> 'b) -> 'a list -> 'b + + +val execute_and_show_progress: + show:bool -> int -> ((unit -> unit) -> 'a) -> unit +val execute_and_show_progress2: + ?show:bool -> int -> ((unit -> unit) -> 'a) -> 'a + +val with_progress_list_metter: + ?show:bool -> ((unit -> unit) -> 'a list -> 'b) -> 'a list -> 'b diff --git a/commons_core/features.ml.in b/commons_core/features.ml.in new file mode 100644 index 0000000..c172b78 --- /dev/null +++ b/commons_core/features.ml.in @@ -0,0 +1,81 @@ +(* yes sometimes cpp is useful *) + +(* old: +note: in addition to Makefile.config, globals/config.ml is also modified +by configure +features.ml: features.ml.cpp Makefile.config + cpp -DFEATURE_GUI=$(FEATURE_GUI) \ + -DFEATURE_MPI=$(FEATURE_MPI) \ + -DFEATURE_PCRE=$(FEATURE_PCRE) \ + features.ml.cpp > features.ml + +clean:: + rm -f features.ml + +beforedepend:: features.ml +*) + +#if FEATURE_MPI==1 + +module Distribution = struct + let map_reduce ?timeout ~fmap ~freduce c xs = + Distribution.map_reduce ?timeout ~fmap ~freduce c xs + + let map_reduce_lazy ?timeout ~fmap ~freduce c fxs = + Distribution.map_reduce_lazy ?timeout ~fmap ~freduce c fxs + + + let under_mpirun () = + Distribution.under_mpirun() + + let set_debug_mpi () = + Distribution.debug_mpi := true + +(* was only when use mpich and the ch4 module. with openmpi, no need. + let mpi_adjust_argv argv = + Distribution.mpi_adjust_argv argv +*) + +end + +#else + +module Distribution = struct + let map_reduce ?timeout ~fmap:map_ex ~freduce:reduce_ex acc xs = + let not_done = [] in + List.fold_left reduce_ex acc (List.map map_ex xs), not_done + + let map_reduce_lazy ?timeout ~fmap:map_ex ~freduce:reduce_ex acc fxs = + let xs = fxs() in (* changed code *) + let not_done = [] in + List.fold_left reduce_ex acc (List.map map_ex xs), not_done + + + let under_mpirun () = + false + + let set_debug_mpi () = + () + +end + +#endif + + +#if FEATURE_REGEXP_PCRE==1 +#else +#endif + +#if FEATURE_BACKTRACE==1 +module Backtrace = struct + let print () = + Backtrace.print () +end +#else + +module Backtrace = struct + let print () = + print_string "no backtrace support, use configure --with-backtrace\n" +end + +#endif diff --git a/commons_core/macro.ml4 b/commons_core/macro.ml4 new file mode 100644 index 0000000..de14969 --- /dev/null +++ b/commons_core/macro.ml4 @@ -0,0 +1,894 @@ +(******************************************************************************) +(* TODO *) +(******************************************************************************) + +(* + macro Or a la merd (try or_left with -> or_right) + + Pcaml.str_item: + [ [ "type"; LIDENT "nogen"; tdl = LIST1 type_declaration SEP "and" -> + <:str_item< type $list:tdl$ >> + | "type"; tdl = LIST1 type_declaration SEP "and" -> + let sil = gen_ioxml_impl loc tdl in + Pcaml.sig_item: + [ [ "type"; LIDENT "nogen"; tdl = LIST1 type_declaration SEP "and" -> + <:sig_item< type $list:tdl$ >> + | "type"; tdl = LIST1 type_declaration SEP "and" -> +need put too in sig_item ? + +look in common.* to do more macro (and also in my docs/langage) + +put the tricks i have in perl + aspect ==> need fix_caml ? or can do with camlp4 (i think yes, but complicated) + profiling mem/cpu/overhead/.... + pr pr2 .... +emacs tricks (C-M-1, ...) +au moins pour le debug + +generalise my stuff so that it is easy to add functionnality + (kind of tools a la haskell je_sais_plus_lenom) + + +faire meilleur lang + where + comprehension + [.. syntax (just from ...) do the desugar as in haskell) + + `...` perhaps with help of lexer (can extend the lexer easily ?) + type class ? + layout ? + section + joly syntax pour les types ([], ()) + autogenerated accessor function + + \x -> ... NON visuellement dur a voir + my stuff with self fun ? + suppr let rec + + +class Show par exemple, peut etre fait +en passant en param a la function genere automatiquement 2 3 foncs + (genre string_of_var, connection_between, ...) ? +can we make class stuff with my fix_caml ? + just need pass around the dictionnary + +pb let obj' = f obj + mieux obj = f obj + encore mieux macro, that "modify" obj + comme let obj ||= f + (ex ++ s'ecrirait let i ||= (+1) +*) + +(******************************************************************************) +(* + design interactivly: (=~ design and call macroexpand of lisp) + $~> ocaml + #load "camlp4o.cma";; + #load "pa_extend.cmo";; + add Extend rule, copy paste in interpreter + Grammar.Entry.parse expr (Stream.of_string "2 + 3");; + expr is already binded with the expr for caml + can use the exception tricks to display (as in exception Print of type_decl) + + using p4 in p4 (with pattern that are quotation) is confusing + => better to do a violent match over the real Ast type + + good example in pa_o.ml (defintion of caml grammar in p4) +*) +(******************************************************************************) +(* + compile it: + ocamlc -c -pp 'camlp4o pa_extend.cmo q_MLast.cmo -impl' -I +camlp4 -impl macro.ml4 + + test output: + camlp4o ./macro.cmo pr_o.cmo common.ml + + use in file (handled by OcamlMakefile): + put at start of your file (*pp camlp4o ./macro.cmo *) + or manually compile with ocamlc -c -pp "camlp4o ./macro.cmo" -g my_file.ml +*) +(******************************************************************************) + +open Pcaml +open MLast + + +(* same as in common *) +let (+>) o f = f o + +let rec zip xs ys = + match (xs,ys) with + | ([],_) -> [] + | (_,[]) -> [] + | (x::xs,y::ys) -> (x,y)::zip xs ys + +let foldl1 p = function x::xs -> List.fold_left p x xs | _ -> failwith "foldl1" + +let rec join_gen a = function + | [] -> [] + | [x] -> [x] + | x::xs -> x::a::(join_gen a xs) + +let _counter = ref 0 +let counter () = (_counter := !_counter +1; !_counter) + + +(* just cos dont want care about location and pass it around to each func *) +(* old: let l = (1,1) *) +let l = (Lexing.dummy_pos, Lexing.dummy_pos) + +(******************************************************************************) + +(* inspired by an example in the camlp4 tutorial + NEED recent version of camlp4 > 3.06+6 (available in the cvs only) + + update=tywith do better ? ioXml do better ? + update: I made this a long time ago, maybe in 2001, long before + tywith, or typeconf, or sexplib, json-static. It was working but limited + to not too complex type, it has no object or module support I think. So + tywith/typeconf were definitely better (and generic). + + It auto-genarate string_of_ and print_ function. + After defining a type, you can normally use the corresponding string_of function. + For polymorphic type, you need to pass as a parameter the string_of function + of the corresponding polymorphic variable + + ex: + from "type t = int * int" + it generates + let rec string_of_t a0 = + match a0 with + a24, a25 -> ((("(" ^ string_of_int a24) ^ ",") ^ string_of_int a25) ^ ")" + and print_t a = print_string (string_of_t a) + + from "type ('a, 'b) either = Left of 'a | Right of 'b" + it generates + let rec string_of_either (str__of_a, str__of_b) a0 = + match a0 with + Left a24 -> (("Left" ^ "(") ^ str__of_a a24) ^ ")" + | Right a26 -> (("Right" ^ "(") ^ str__of_b a26) ^ ")" + and print_either funs a = print_string (string_of_either funs a) + + + + as i have not access to the source file of caml, you certainly have to put + in one of your source file those definitions: + + let string_of_list f xs = + "[" ^ (xs +> List.map f +> String.concat ";" ) ^ "]" + + let string_of_array f xs = + "[|" ^ (xs +> Array.to_list +> List.map f +> String.concat ";") ^ "|]" + + let string_of_option f = function + | None -> "None " + | Some x -> "Some " ^ (f x) + + let print_bool x = print_string (if x then "True" else "False") + + let print_list pr xs = + do { print_string "["; List.iter (fun x -> pr x; print_string ",") xs; print_string "]" } + + let print_option pr = function + | None -> print_string "None" + | Some x -> print_string "Some ("; pr x; print_string ")" + + + +*) + +(* COMMENT START +let _ = + DELETE_RULE + Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and" + END; + +EXTEND + Pcaml.str_item: + [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" -> + + let name () = "a" ^ string_of_int (counter ()) in + + (* subtil bug, when we have only one param, we cant construct a tuple with one param, + we should think that (1) and 1 are treated the same way, but seems this work + is done in caml in the parser, which mean that we must not give to caml an Ast with + a 1-uple + *) + let ex_tuple = function + | [] -> failwith "pb" + | [x] -> x + | xs -> ExTup (l,xs) + in + let pa_tuple = function + | [] -> failwith "pb" + | [x] -> x + | xs -> PaTup (l,xs) + in + + let funcs = tdl +> List.map (fun ((l,str), param_polymorphs, ctyp, z) -> + let join_app xs = xs +> foldl1 (fun a e -> <:expr< $a$ ^ $e$>>) in + let join_virg xs = xs +> join_gen (ExStr (l, ",")) in + + let name_module_func = function + | TyLid (l, s) -> ExLid(l, "string_of_" ^ s) + | TyAcc (_, TyUid (_,file), TyLid (_,s)) -> + (* Module.string_of .... + ExAcc(l, ExUid (l,file), ExLid(l, "string_of_" ^ s)) + but dont work that much cos builtin lib or modules have not those function + *) + ExLid(l, String.lowercase file ^ "_" ^ "string_of_" ^ s) + | _ -> failwith "pb" + in + (* TODOSTYLE? function fmatch id patt expr who put the None, ... *) + let rec body_ctyp id = function + | (TyLid (_) | TyAcc (_)) as c -> ExApp (l,name_module_func c, ExLid (l,id)) + (* | TyUid of loc and string *) + + | TyQuo (l, s) -> ExApp (l, ExLid(l, "str__of_" ^ s), ExLid (l,id)) + | TySum (l,_bool, xs) -> + ExMat(l, ExLid (l, id), + xs +> List.map (fun (l, s, ctyps) -> + let newids = xs +> List.map (fun _ -> name ()) in + match ctyps, newids with + | ([],_) -> (PaUid(l, s), None, ExStr (l,s)) + | (x::xs,id::ids) -> + let patt = zip xs ids +> + List.fold_left + (fun a (e,id) -> PaApp (l, a, PaLid (l,id))) + (PaApp (l, PaUid(l, s), PaLid(l, id))) in + (patt, None, + zip (x::xs) (id::ids) +> List.map (fun (e,id) -> body_ctyp id e) +> join_virg +> + (fun xs -> [ExStr (l,s); ExStr (l,"(")] @ xs @ [ExStr (l,")")]) +> join_app + ) + | _ -> failwith "pb" + ) + ) + | TyTup (l, xs) -> + let newids = xs +> List.map (fun _ -> name ()) in + ExMat(l, ExLid (l,id), + [PaTup(l, newids +> List.map (fun id -> PaLid (l,id))), + None, + zip xs newids +> List.map (fun (e,id) -> body_ctyp id e) +> join_virg +> + (fun xs -> [ExStr (l,"(")] @ xs @ [ExStr (l,")")]) +> join_app + ] + ) + | TyArr (l,c1,c2) -> ExStr(l, "") + | TyApp (l,c1,c2) -> + let rec extract_all_params acc = function + | TyApp (l,c1', c2') -> extract_all_params (acc @ [c2']) c1' + | x -> (x, acc) in + let (type_parameted, params) = extract_all_params [] (TyApp (l, c1, c2)) in + let funcs = params +> List.map (fun c -> + let id = name () in + let f = body_ctyp id c in + ExFun (l, [PaLid(l, id), None, f])) + in + (match type_parameted with + | (TyLid (_) | TyAcc (_)) as c -> + ExApp (l, ExApp (l, name_module_func c, ex_tuple funcs), ExLid (l,id)) + | _ -> ExStr (l,"") + ) + | TyRec (l, _bool, xs) -> + let newids = xs +> List.map (fun _ -> name ()) in + ExMat(l, ExLid (l, id), + [ PaRec (l, zip xs newids +> List.map (fun ((_,e,_,_), id) -> PaLid(l, e), PaLid(l, id))), + None, + zip xs newids + +> List.map + (fun ((l,s,_b,e),id) -> [ExStr(l,s); ExStr(l," = ");body_ctyp id e] +> join_app) + +> join_virg + +> (fun xs -> [ExStr (l,"{")] @ xs @ [ExStr (l,"}")]) +> join_app + ]) + + (* TODO when needed + | TyAli of loc and ctyp and ctyp + | TyAny of loc + | TyCls of loc and list string + | TyLab of loc and string and ctyp + | TyMan of loc and ctyp and ctyp + | TyOlb of loc and string and ctyp + | TyPol of loc and list string and ctyp + | TyObj of loc and list (string * ctyp) and bool + | TyVrn of loc and list row_field and option (option (list string)) + and row_field = + | RfTag of string and bool and list ctyp + | RfInh of ctyp + *) + | _ -> (ExStr (l, "")) + + in + let f_str_func_params body = + (* currifie: + param_polymorphs +> List.rev +> List.fold_left (fun acc (str_poly, (_,_)) -> + ExFun(l, [(PaLid (l, name_f_str_params str_poly),None, acc)])) + body + *) + if param_polymorphs = [] then body + else ExFun (l, [pa_tuple + (param_polymorphs +> List.map (fun (str_poly,(_,_)) -> + PaLid (l, "str__of_" ^ str_poly))), + None, body]) + in + + [(PaLid (l, "string_of_" ^ str), (* let string_of... *) + f_str_func_params (* str__a str__b ... *) + (ExFun(l, [(PaLid (l,"a0"), None, (* a0 = .... *) + (body_ctyp "a0" ctyp))]))) (* match a with .... *) + + ;(PaLid (l, "print_" ^ str), + (if param_polymorphs = [] + then fun e -> e + else fun e -> (ExFun (l, [PaLid (l, "funs"), None, e])) + ) + (ExFun (l, [(PaLid (l,"a")), None, + ExApp (l, ExLid (l, "print_string"), + if param_polymorphs = [] + then ExApp(l, ExLid (l, "string_of_" ^ str), ExLid (l, "a")) + else ExApp (l, + ExApp (l, ExLid (l, "string_of_" ^ str), + ExLid (l, "funs")), + ExLid (l, "a")))]))) + ]) + in + let recursif = true in + (StDcl (loc, [(StTyp (loc, tdl));StVal (loc, recursif, funcs +> List.flatten)])) +]] + ; + END +;; + +END COMMENT *) +(* +let x = Grammar.Entry.parse str_item (Stream.of_string "type synon = int * int") +let x = Grammar.Entry.parse str_item (Stream.of_string "type 'a numdict = C of ('a -> 'a)") +let x = Grammar.Entry.parse str_item (Stream.of_string "type test = C1 of string * string | C2 and t2 = C3 | C4") +let x = Grammar.Entry.parse str_item (Stream.of_string "type ('a,'b) test = C1 of 'a | C2 of 'b") +let x = Grammar.Entry.parse str_item (Stream.of_string "type point = {x: int; y:int}") +let x = Grammar.Entry.parse str_item (Stream.of_string "type ('a,'b) assoc = ('a * 'b) list") +let x = Grammar.Entry.parse str_item (Stream.of_string "type ('a,'b) vec = ('a , 'b) assoc") +let x = Grammar.Entry.parse str_item (Stream.of_string "type robot_list = robot IntMap.t") + +let x = Grammar.Entry.parse expr (Stream.of_string "match a with {x = a; y = b} -> a + b") +let x = Grammar.Entry.parse expr (Stream.of_string "match a with (a,b,c,d) -> a + b + c + d") +let x = Grammar.Entry.parse expr (Stream.of_string "match a with C1 (s, s2) -> s | C2 s -> s | C3 -> s") +let x = Grammar.Entry.parse str_item (Stream.of_string "let rec fact x = if x = 0 then 1 else x * fact (x -1);; ") +let x = Grammar.Entry.parse str_item (Stream.of_string "let print_toto f a = function () -> ();; ") +let x = Grammar.Entry.parse str_item (Stream.of_string "let print_toto f1 f2 a = function () -> ();; ") +let x = Grammar.Entry.parse str_item (Stream.of_string "let print_toto (f1,f2) a = function () -> ();; ") +let x = Grammar.Entry.parse str_item (Stream.of_string "let print_assoc (f1,f2) a0 = print_list (fun a -> function () -> ());; ") +let x = Grammar.Entry.parse str_item (Stream.of_string "let print_assoc (f1,f2) a0 = IntMap.print_list (fun a -> function () -> ());; ") + + +let x = Grammar.Entry.parse expr (Stream.of_string "1 + 1") +let x = Grammar.Entry.parse expr (Stream.of_string "\"tptp\" ^ string_of a") +let x = Grammar.Entry.parse expr (Stream.of_string "print_string (string_of a)") + +let t = macro_expand "type t = int * int;;" +let t = macro_expand "type test = C1 of string * string | C2 and t2 = C3 | C4" +let t = macro_expand "type 'a test = C1 of string * string | C2 | C3 of 'a and t2 = C3 | C4" +let t = macro_expand "type ('a,'b) either = Left of 'a | Right of 'b" +let t = macro_expand "type color_test = Red | Yellow" +let t = macro_expand "type ('a,'b) assoc = ('a * 'b) list" +let t = macro_expand "type 'a numdict = C of ('a -> 'a)" +let t = macro_expand "type 'a numdict = NumDict of (('a-> 'a -> 'a) * ('a-> 'a -> 'a) * ('a-> 'a -> 'a) * ('a -> 'a))" +let t = macro_expand "type 'a bintree = Leaf of 'a | Branch of ('a bintree * 'a bintree)" +let t = macro_expand "type ('a,'b) assoc = ('a * 'b) list" +let t = macro_expand "type ('a,'b) vec = ('a , 'b) assoc" +let t = macro_expand "type vector = (float * float * float)" +let t = macro_expand "type point = {x: int; y:int}" +let t = macro_expand "type robot_list = robot IntMap.t" +let t = macro_expand "type robot_list = IntMap.t" +*) +(******************************************************************************) +(* +map +fold +fold_some +apres pourra faire facilement des trucs du genre get_all_vars, + ... + + facto code ? + +'a 'b --> 'c 'd pour map + +intmap fold = ? +les fold des libs de caml = ? + +*) + + +(******************************************************************************) + +(* +EXTEND + expr: BEFORE "simple" + [[ "do"; "{"; e1 = expr; "}" -> + <:expr< do { $e1$ } >> ]]; +END;; +*) +(* can also do <:expr< let _ = $e1$ in () >> ]]; *) + +EXTEND + expr: BEFORE "simple" + [[ "do"; "{"; e1 = expr; "}" -> + ExSeq ((Lexing.dummy_pos,Lexing.dummy_pos),[e1]) + ]]; +END;; + + +(******************************************************************************) +(* use: + let g = (x + y) + where x = 1 + and y = 1 +*) + +EXTEND + expr: + [[ e2 = expr; "where"; rest = LIST1 Pcaml.let_binding SEP "and" -> + rest +> List.rev +> List.fold_left (fun acc (patt, expr) -> + ExLet(l, false, [patt,expr], acc)) e2 + ]]; +END;; + +(* +let x = Grammar.Entry.parse expr (Stream.of_string "let x = 1 in let y a = 1 in x + y");; +let t = macro_expand "let2 x = 1 in 1" +let t = macro_expand "x where x = 1" +let t = macro_expand "x + y where x = 1 and y = 1" +*) + +(******************************************************************************) +(* +use: + { x + y | (x,y) <- [(1,1);(2,2);(3,3)] and x > 2 and y < 3} + TODO support only one generator for the moment +*) +(* +EXTEND + expr: + [[ + "{{"; e1 = expr; "|"; p1 = patt; "<-"; e2 = expr; "}}" -> + let maps = (ExAcc (l, ExUid (l, "List"), ExLid (l,"map"))) in + ExApp (l, ExApp(l, maps, + ExFun (l, [p1, None, e1]) + ), e2) + | "{{"; e1 = expr; "|"; p1 = patt; "<-"; e2 = expr; "and"; e3s = LIST1 expr SEP "and"; "}}" -> + let maps = (ExAcc (l, ExUid (l, "List"), ExLid (l,"map"))) in + let filters =(ExAcc (l, ExUid (l, "List"), ExLid (l,"filter"))) in + + ExApp (l, + ExApp(l, maps,ExFun (l, [p1, None, e1])), + e3s +> List.fold_left (fun acc expr -> + ExApp (l, + ExApp(l, filters, ExFun(l, [p1, None, expr])), + acc) + ) + e2) + ]]; +END;; +*) +(* + [ expr1 | x <- expr2] ----> expr2 +> List.map (fun x -> expr1) + [ expr1 | x <- expr2, x > 2] ----> expr2 +> List.filter (fun x -> x > 2) +> List.map (fun x -> expr1) + TODO better than | to separate filter +*) + +(******************************************************************************) +(* +use: + let x = {1 .. 10} +> List.map (fun i -> i) + you need space between token (dont know really why) + you need the enum function: let rec enum x n = if x = n then [n] else x::enum (x+1) n + +*) +(* +EXTEND + expr: + [[ + "{{"; e1 = expr; ".."; e2 = expr; "}}" -> + <:expr> + ]]; +END;; +*) +(******************************************************************************) + +(* +EXTEND + expr: BEFORE "simple" + [[ + e1 = expr; "to"; e2 = expr; "to"; e3 = expr -> + <:expr> + ]]; +END;; +*) + + +(******************************************************************************) +(* + let add_update_plan w e = w.update_plan <- e::w.update_plan + sucks cos no first class field + perhaps need a preprocessor over record to let the field be first class + indeed :) camlp4 +*) + +EXTEND + expr:BEFORE "simple" + [ [ + "modify"; record = NEXT; "."; field = LIDENT ; f = NEXT -> + <:expr< $record$.$lid:field$ := $f$ $record$.$lid:field$>> + ]]; +END;; + +(* + # type point = {mutable x:int; mutable y:int};; + # let o = { x= 0; y = 0};; + # modify o.y succ;; + + I haven't tested this extension any further, but the main issue I can see is + that "modify" becomes a keyword, which can be a problem if there are some + variables with that name in your code. + + -- Virgile Prevosto +*) + +(******************************************************************************) +(* +Original version, without quotation +let _ = + DELETE_RULE + Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and" + END; + +EXTEND + Pcaml.str_item: + [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" -> + + let name () = "a" ^ string_of_int (counter ()) in + + (* subtil bug, when we have only one param, we cant construct a tuple with one param, + we should think that (1) and 1 are treated the same way, but seems this work + is done in caml in the parser, which mean that we must not give to caml an Ast with + a 1-uple + *) + let ex_tuple = function + | [] -> failwith "pb" + | [x] -> x + | xs -> ExTup (l,xs) + in + let pa_tuple = function + | [] -> failwith "pb" + | [x] -> x + | xs -> PaTup (l,xs) + in + + let funcs = tdl +> List.map (fun ((l,str), param_polymorphs, ctyp, z) -> + let join_app xs = xs +> foldl1 (fun a e -> ExApp(l, ExApp (l, ExLid (l, "^"), a), e)) in + let join_virg xs = xs +> join_gen (ExStr (l, ",")) in + + let name_module_func = function + | TyLid (l, s) -> ExLid(l, "string_of_" ^ s) + | TyAcc (_, TyUid (_,file), TyLid (_,s)) -> ExAcc(l, ExUid (l,file), ExLid(l, "string_of_" ^ s)) + | _ -> failwith "pb" + in + (* TODOSTYLE? function fmatch id patt expr who put the None, ... *) + let rec body_ctyp id = function + | (TyLid (_) | TyAcc (_)) as c -> ExApp (l,name_module_func c, ExLid (l,id)) + (* | TyUid of loc and string *) + + | TyQuo (l, s) -> ExApp (l, ExLid(l, "str__of_" ^ s), ExLid (l,id)) + | TySum (l, xs) -> + ExMat(l, ExLid (l, id), + xs +> List.map (fun (l, s, ctyps) -> + let newids = xs +> List.map (fun _ -> name ()) in + match ctyps, newids with + | ([],_) -> (PaUid(l, s), None, ExStr (l,s)) + | (x::xs,id::ids) -> + let patt = zip xs ids +> List.fold_left + (fun a (e,id) -> PaApp (l, a, PaLid (l,id)) + ) (PaApp (l, PaUid(l, s), PaLid(l, id))) in + (patt, None, + zip (x::xs) (id::ids) +> List.map (fun (e,id) -> body_ctyp id e) +> join_virg +> + (fun xs -> [ExStr (l,s); ExStr (l,"(")] @ xs @ [ExStr (l,")")]) +> join_app + ) + | _ -> failwith "pb" + ) + ) + | TyTup (l, xs) -> + let newids = xs +> List.map (fun _ -> name ()) in + ExMat(l, ExLid (l,id), + [PaTup(l, newids +> List.map (fun id -> PaLid (l,id))), + None, + zip xs newids +> List.map (fun (e,id) -> body_ctyp id e) +> join_virg +> + (fun xs -> [ExStr (l,"(")] @ xs @ [ExStr (l,")")]) +> join_app + ] + ) + | TyArr (l,c1,c2) -> ExStr(l, "") + | TyApp (l,c1,c2) -> + let rec extract_all_params acc = function + | TyApp (l,c1', c2') -> extract_all_params (acc @ [c2']) c1' + | x -> (x, acc) in + let (type_parameted, params) = extract_all_params [] (TyApp (l, c1, c2)) in + let funcs = params +> List.map (fun c -> + let id = name () in + let f = body_ctyp id c in + ExFun (l, [PaLid(l, id), None, f])) + in + (match type_parameted with + | (TyLid (_) | TyAcc (_)) as c -> + ExApp (l, ExApp (l, name_module_func c, ex_tuple funcs), ExLid (l,id)) + | _ -> ExStr (l,"") + ) + | TyRec (l, xs) -> + let newids = xs +> List.map (fun _ -> name ()) in + ExMat(l, ExLid (l, id), + [ PaRec (l, zip xs newids +> List.map (fun ((_,e,_,_), id) -> PaLid(l, e), PaLid(l, id))), + None, + zip xs newids + +> List.map + (fun ((l,s,_b,e),id) -> [ExStr(l,s); ExStr(l," = ");body_ctyp id e] +> join_app) + +> join_virg + +> (fun xs -> [ExStr (l,"{")] @ xs @ [ExStr (l,"}")]) +> join_app + ]) + + (* TODO when needed + | TyAli of loc and ctyp and ctyp + | TyAny of loc + | TyCls of loc and list string + | TyLab of loc and string and ctyp + | TyMan of loc and ctyp and ctyp + | TyOlb of loc and string and ctyp + | TyPol of loc and list string and ctyp + | TyObj of loc and list (string * ctyp) and bool + | TyVrn of loc and list row_field and option (option (list string)) + and row_field = + | RfTag of string and bool and list ctyp + | RfInh of ctyp + *) + | _ -> (ExStr (l, "")) + + in + let f_str_func_params body = + (* currifie: + param_polymorphs +> List.rev +> List.fold_left (fun acc (str_poly, (_,_)) -> + ExFun(l, [(PaLid (l, name_f_str_params str_poly),None, acc)])) + body + *) + if param_polymorphs = [] then body + else ExFun (l, [pa_tuple + (param_polymorphs +> List.map (fun (str_poly,(_,_)) -> + PaLid (l, "str__of_" ^ str_poly))), + None, body]) + in + + [(PaLid (l, "string_of_" ^ str), (* let string_of... *) + f_str_func_params (* str__a str__b ... *) + (ExFun(l, [(PaLid (l,"a0"), None, (* a0 = .... *) + (body_ctyp "a0" ctyp))]))) (* match a with .... *) + + ;(PaLid (l, "print_" ^ str), + (if param_polymorphs = [] + then fun e -> e + else fun e -> (ExFun (l, [PaLid (l, "funs"), None, e])) + ) + (ExFun (l, [(PaLid (l,"a")), None, + ExApp (l, ExLid (l, "print_string"), + if param_polymorphs = [] + then ExApp(l, ExLid (l, "string_of_" ^ str), ExLid (l, "a")) + else ExApp (l, + ExApp (l, ExLid (l, "string_of_" ^ str), + ExLid (l, "funs")), + ExLid (l, "a")))]))) + ]) + in + let recursif = true in + (StDcl (loc, [(StTyp (loc, tdl));StVal (loc, recursif, funcs +> List.flatten)])) +]] + ; + END +;; + +*) +(******************************************************************************) + +(* +let gen_print_funs loc tdl = + <:str_item< not yet implemented >> + + let _ = + EXTEND + Pcaml.str_item: + [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" -> + let si1 = <:str_item< type $list:tdl$ >> in + let si2 = gen_print_funs loc tdl in + <:str_item< declare $si1$; $si2$; end >> ] ] + ; + END + +*) +(* +let fun_name n = "print_" ^ n +let fun_param_name n = "pr_" ^ n +let param_name cnt = "x" ^ string_of_int cnt + +let list_mapi f l = + let rec loop cnt = + function + x :: l -> f cnt x :: loop (cnt + 1) l + | [] -> [] + in + loop 1 l + +let gen_print_type loc t = + let rec eot = + function + <:ctyp< $t1$ $t2$ >> -> <:expr< $eot t1$ $eot t2$ >> + | <:ctyp< $lid:s$ >> -> <:expr< $lid:fun_name s$ >> + | <:ctyp< '$s$ >> -> <:expr< $lid:fun_param_name s$ >> + | _ -> <:expr< fun _ -> print_string "..." >> + in + eot t + +let gen_call loc n f = <:expr< $f$ $lid:param_name n$ >> + + let gen_print_cons_patt loc c tl = + let pl = + list_mapi (fun n _ -> <:patt< $lid:param_name n$ >>) + tl + in + List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) + <:patt< $uid:c$ >> pl + +let gen_print_con_extra_syntax loc el = + let rec loop = + function + [] | [_] as e -> e + | e :: el -> e :: <:expr< print_string ", " >> :: loop el + in + <:expr< print_string " (" >> :: loop el @ + [<:expr< print_string ")" >>] + +let gen_print_cons_expr loc c tl = + let pr_con = <:expr< print_string $str:c$ >> in + match tl with + [] -> pr_con + | _ -> + let pr_params = + let type_funs = List.map (gen_print_type loc) tl in + list_mapi (gen_call loc) type_funs + in + let pr_all = gen_print_con_extra_syntax loc pr_params in + let el = pr_con :: pr_all in + <:expr< do { $list:el$ } >> + + let gen_print_cons (loc, c, tl) = + let p = gen_print_cons_patt loc c tl in + let e = gen_print_cons_expr loc c tl in + p, None, e + +let gen_print_sum loc cdl = + let pwel = List.map gen_print_cons cdl in + <:expr< fun [ $list:pwel$ ] >> + +let gen_one_print_fun loc ((loc, n), tpl, tk, cl) = + let body = + match tk with + <:ctyp< [ $list:cdl$ ] >> -> gen_print_sum loc cdl + | _ -> <:expr< fun _ -> failwith $str:fun_name n$ >> + in + let body = + List.fold_right + (fun (v, _) e -> + <:expr< fun $lid:fun_param_name v$ -> $e$ >>) + tpl body + in + <:patt< $lid:fun_name n$ >>, body + +let gen_print_funs loc tdl = + let pel = List.map (gen_one_print_fun loc) tdl in + <:str_item< value rec $list:pel$ >> + +*) +(* + let _ = + DELETE_RULE + Pcaml.str_item: "type"; LIST1 Pcaml.type_declaration SEP "and" + END; + EXTEND + Pcaml.str_item: + [ [ "type"; tdl = LIST1 Pcaml.type_declaration SEP "and" -> + let si1 = <:str_item< type $list:tdl$ >> in + let si2 = gen_print_funs loc tdl in + <:str_item< declare $si1$; $si2$; end >> ] ] + ; + END +*) +(* by author of camlp4 *) + +(******************************************************************************) +(* + # let expand _ s = + match s with + "PI" -> "3.14159" + | "goban" -> "19*19" + | "chess" -> "8*8" + | "ZERO" -> "0" + | "ONE" -> "1" + | _ -> "\"" ^ s ^ "\"" + ;; + + Let us call the quotation ``foo''. We can associate the quotation ``foo'' to the above expander ``expand'' by typing: + + # Quotation.add "foo" (Quotation.ExStr expand);; + + We can experiment the new quotation immediately: + + # <:foo>;; + - : float = 3.14159 +*) + +(******************************************************************************) +(* +let add_infix lev op = + EXTEND + expr: LEVEL $lev$ + [ [ x = expr; $op$; y = expr -> <:expr< $lid:op$ $x$ $y$ >> ] ] + ; + END;; +*) + +(******************************************************************************) + +(* + type term = + Var of string + | Func of string * term + | Appl of term * term + ;; + + The first case, Var, represents variables. + + The second case, Func, represents functions. Its first parameter is the function parameter and its second parameter + the function body. We write that in concrete syntax [parameter]body. + + The third case, App, represents an application of two lambda terms. We write that in concrete syntax (term1 term2). + + But, for the moment, we just defined a type term, and we can just write these terms using the constructors. Here is + an example: + + let id = Func ("x", Var "x") + let k = Func ("x", Func ("y", Var "x")) + let s = + Func ("x", Func ("y", Func ("z", + Appl (Appl (Var "x", Var "y"), Appl (Var "x", Var "z"))))) + let delta = Func ("x", Appl (Var "x", Var "x")) + let omega = Appl (delta, delta) + + A nice quotation expander would allow us to use concrete syntax. The same piece of program could look like this, + which is more readable: + + let id = << [x]x >> + let k = << [x][y]x >> + let s = << [x][y][z]((x y) (x z)) >> + let delta = << [x](x x) >> + let omega = << (^delta ^delta) >> + + +let gram = Grammar.gcreate (Plexer.gmake ());; + let term_eoi = Grammar.Entry.create gram "term";; + let term = Grammar.Entry.create gram "term";; + EXTEND + term_eoi: [ [ x = term; EOI -> x ] ]; + term: + [ [ "["; x = LIDENT; "]"; t = term -> <:expr< Func $str:x$ $t$ >> + | "("; t1 = term; t2 = term; ")" -> <:expr< Appl $t1$ $t2$ >> + | x = LIDENT -> <:expr< Var $str:x$ >> ] ] + ; + END;; + let term_exp s = Grammar.Entry.parse term_eoi (Stream.of_string s);; + let term_pat s = failwith "not implemented term_pat";; + Quotation.add "term" (Quotation.ExAst (term_exp, term_pat));; + Quotation.default := "term";; +*) + +(******************************************************************************) diff --git a/external/Makefile b/external/Makefile new file mode 100644 index 0000000..762b105 --- /dev/null +++ b/external/Makefile @@ -0,0 +1,5 @@ + +# alternatives: godi, opam + +install: + echo TODO \ No newline at end of file diff --git a/external/dependencies.txt b/external/dependencies.txt new file mode 100644 index 0000000..39d891c --- /dev/null +++ b/external/dependencies.txt @@ -0,0 +1,16 @@ +stdlib/: used by everthing + +ocamlcairo/: used by codemap/codegraph, core graphics library. +ocamlgtk/: used by codemap/codegraph, mostly for interactive menus and basic + UI chrome. + +ocamlgraph/: used by commons/graph.ml and so graph_code, also a bit by + lang_html/? TODO why dependencies to codegraph is now shown in cg? + +javalib/: used by lang_bytecode/ +ocamlzip/: used by externals/javalib (used itself by lang_bytecode/) +extlib/: used by externals/javalib (used itself by lang_bytecode/) +ptrees/: used by javalib/ (TODO: deps not in codegraph because functor) + +bddbddb/: used by codequery -datalog (actually not ocaml code!) +swiprolog/: used by codequery (also not ocaml code) diff --git a/external/jsonwheel/.depend b/external/jsonwheel/.depend new file mode 100644 index 0000000..44111b9 --- /dev/null +++ b/external/jsonwheel/.depend @@ -0,0 +1,17 @@ +json_in.cmo : json_type.cmi json_parser.cmi json_lexer.cmo +json_in.cmx : json_type.cmx json_parser.cmx json_lexer.cmx +json_io.cmo : json_type.cmi json_parser.cmi json_lexer.cmo json_io.cmi +json_io.cmx : json_type.cmx json_parser.cmx json_lexer.cmx json_io.cmi +json_io.cmi : json_type.cmi +json_lexer.cmo : netconversion2.cmo json_type.cmi json_parser.cmi +json_lexer.cmx : netconversion2.cmx json_type.cmx json_parser.cmx +json_out.cmo : json_type.cmi +json_out.cmx : json_type.cmx +json_parser.cmo : json_type.cmi json_parser.cmi +json_parser.cmx : json_type.cmx json_parser.cmi +json_parser.cmi : json_type.cmi +json_type.cmo : json_type.cmi +json_type.cmx : json_type.cmi +json_type.cmi : +netconversion2.cmo : +netconversion2.cmx : diff --git a/external/jsonwheel/META b/external/jsonwheel/META new file mode 100644 index 0000000..49abe8b --- /dev/null +++ b/external/jsonwheel/META @@ -0,0 +1,4 @@ +description = "jsonwheel" +requires = "unix num str bigarray" +archive(byte) = "jsonwheel.cma" +archive(native) = "jsonwheel.cmxa" diff --git a/external/jsonwheel/Makefile b/external/jsonwheel/Makefile new file mode 100644 index 0000000..f35d052 --- /dev/null +++ b/external/jsonwheel/Makefile @@ -0,0 +1,118 @@ +############################################################################## +# Variables +############################################################################## + +SRC= json_type.ml \ + json_out.ml \ + netconversion2.ml \ + json_parser.ml \ + json_lexer.ml \ + json_in.ml \ + json_io.ml + +TARGET=jsonwheel + +INCLUDES= +#-I +camlp4 +SYSLIBS= str.cma unix.cma bigarray.cma num.cma + +############################################################################## +# Generic variables +############################################################################## + +#dont use -custom, it makes the bytecode unportable. +OCAMLCFLAGS= -g -dtypes $(OCAMLCFLAGS_EXTRA) +#-for-pack Sexplib + +# This flag is also used in subdirectories so don't change its name here. +OPTFLAGS= + +OCAMLC=ocamlc$(OPTBIN) $(OCAMLCFLAGS) $(INCLUDES) $(SYSINCLUDES) -thread +OCAMLOPT=ocamlopt$(OPTBIN) $(OPTFLAGS) $(INCLUDES) $(SYSINCLUDES) -thread +OCAMLLEX=ocamllex #-ml # -ml for debugging lexer, but slightly slower +OCAMLYACC=ocamlyacc -v +OCAMLDEP=ocamldep $(INCLUDES) +OCAMLMKTOP=ocamlmktop -g -custom $(INCLUDES) -thread + +#-ccopt -static +STATIC= + +############################################################################## +# Top rules +############################################################################## + +OBJS = $(SRC:.ml=.cmo) +OPTOBJS = $(SRC:.ml=.cmx) + +all: $(TARGET).cma +all.opt: $(TARGET).cmxa + +$(TARGET).cma: $(OBJS) + $(OCAMLC) -a -o $(TARGET).cma $(OBJS) + +$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa) + $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS) + +$(TARGET).top: $(OBJS) $(LIBS) + $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS) + +clean:: + rm -f $(TARGET).top + +#pad: we include in the git repo already the generated file +#json_lexer.ml: json_lexer.mll +# $(OCAMLLEX) $< +#dist_clean:: +# rm -f json_lexer.ml +#beforedepend:: json_lexer.ml + +#json_parser.ml json_parser.mli: json_parser.mly +# $(OCAMLYACC) $< +#dist_clean:: +# rm -f json_parser.ml json_parser.mli json_parser.output +#beforedepend:: json_parser.ml json_parser.mli + +############################################################################## +# install +############################################################################## +LIBNAME=jsonwheel +EXPORTSRC=json_io.mli json_parser.mli json_type.mli + +install-findlib: $(LIBNAME).cma $(LIBNAME).cmxa + ocamlfind install $(LIBNAME) META \ + $(LIBNAME).cma $(LIBNAME).cmxa $(LIBNAME).a *.cmi $(EXPORTSRC) + +uninstall-findlib:: + ocamlfind remove $(LIBNAME) + + +############################################################################## +# Generic rules +############################################################################## + +.SUFFIXES: .ml .mli .cmo .cmi .cmx + +.ml.cmo: + $(OCAMLC) -c $< +.mli.cmi: + $(OCAMLC) -c $< +.ml.cmx: + $(OCAMLOPT) -c $< + +.ml.mldepend: + $(OCAMLC) -i $< + +clean:: + rm -f *.cm[ioxa] *.o *.a *.cmxa *.annot *.cmt *.cmti +clean:: + rm -f *~ .*~ gmon.out #*# + +beforedepend:: + +depend:: beforedepend + $(OCAMLDEP) *.mli *.ml > .depend + +distclean:: + rm -f .depend + +-include .depend diff --git a/external/jsonwheel/copyright.txt b/external/jsonwheel/copyright.txt new file mode 100644 index 0000000..3e8f316 --- /dev/null +++ b/external/jsonwheel/copyright.txt @@ -0,0 +1,26 @@ +Copyright (c) 2006 Wink Technologies, Inc. +Copyright (c) 2006, 2009 Martin Jambon +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 name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(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/external/jsonwheel/json_in.ml b/external/jsonwheel/json_in.ml new file mode 100644 index 0000000..078837f --- /dev/null +++ b/external/jsonwheel/json_in.ml @@ -0,0 +1,51 @@ +type t = Json_type.t +open Json_type + + +let filter_result x = + Browse.assert_object_or_array x; + x + + +let check_channel_is_utf8 ic = + let start = pos_in ic in + let encoding = + try + let c1 = input_char ic in + let c2 = input_char ic in + let c3 = input_char ic in + let c4 = input_char ic in + Json_lexer.detect_encoding c1 c2 c3 c4 + with End_of_file -> `UTF8 in + if encoding <> `UTF8 then + json_error "Only UTF-8 encoding is supported"; + (try seek_in ic start + with _ -> json_error "Not a regular file") + +(* from_channel and from_channel4 work + only on seekable devices (regular files) *) +let from_channel p recursive file ic = + check_channel_is_utf8 ic; + let lexbuf = Lexing.from_channel ic in + Json_lexer.set_file_name lexbuf file; + let j = + Json_parser.main + (Json_lexer.token p) + lexbuf + in + if recursive then j + else filter_result j + +let load_json + ?allow_comments ?allow_nan ?big_int_mode ?(recursive = false) + file = + let ic = open_in file in + let x = + let p = + Json_lexer.make_param ?allow_comments ?allow_nan ?big_int_mode () in + try `Result (from_channel p recursive file ic) + with e -> `Exn e in + close_in ic; + match x with + `Result x -> x + | `Exn e -> raise e diff --git a/external/jsonwheel/json_io.ml b/external/jsonwheel/json_io.ml new file mode 100644 index 0000000..6480a43 --- /dev/null +++ b/external/jsonwheel/json_io.ml @@ -0,0 +1,421 @@ +type t = Json_type.t +open Json_type + + +(*** Parsing ***) + +let check_string_is_utf8 s = + let encoding = + if String.length s < 4 then `UTF8 + else Json_lexer.detect_encoding s.[0] s.[1] s.[2] s.[3] in + if encoding <> `UTF8 then + json_error "Only UTF-8 encoding is supported" + +let filter_result x = + Browse.assert_object_or_array x; + x + +let json_of_string + ?allow_comments + ?allow_nan + ?big_int_mode + ?(recursive = false) + s = + check_string_is_utf8 s; + let p = Json_lexer.make_param ?allow_comments ?allow_nan ?big_int_mode () in + let j = + Json_parser.main + (Json_lexer.token p) + (Lexing.from_string s) + in + if not recursive then filter_result j + else j + + +let check_channel_is_utf8 ic = + let start = pos_in ic in + let encoding = + try + let c1 = input_char ic in + let c2 = input_char ic in + let c3 = input_char ic in + let c4 = input_char ic in + Json_lexer.detect_encoding c1 c2 c3 c4 + with End_of_file -> `UTF8 in + if encoding <> `UTF8 then + json_error "Only UTF-8 encoding is supported"; + (try seek_in ic start + with _ -> json_error "Not a regular file") + +(* from_channel and from_channel4 work + only on seekable devices (regular files) *) +let from_channel p recursive file ic = + check_channel_is_utf8 ic; + let lexbuf = Lexing.from_channel ic in + Json_lexer.set_file_name lexbuf file; + let j = + Json_parser.main + (Json_lexer.token p) + lexbuf + in + if recursive then j + else filter_result j + + +let load_json + ?allow_comments ?allow_nan ?big_int_mode ?(recursive = false) + file = + let ic = open_in file in + let x = + let p = + Json_lexer.make_param ?allow_comments ?allow_nan ?big_int_mode () in + try `Result (from_channel p recursive file ic) + with e -> `Exn e in + close_in ic; + match x with + `Result x -> x + | `Exn e -> raise e + + +(*** Printing ***) + +(* JSON does not allow rendering floats with a trailing dot: that is, + 1234. is not allowed, but 1234.0 is ok. here, we add a '0' if + string_of_int result in a trailing dot *) +let fprint_float allow_nan fmt f = + match classify_float f with + FP_nan -> + if allow_nan then Format.fprintf fmt "NaN" + else json_error "Not allowed to serialize NaN value" + | FP_infinite -> + if allow_nan then + if f < 0. then Format.fprintf fmt "-Infinity" + else Format.fprintf fmt "Infinity" + else json_error "Not allowed to serialize infinite value" + | FP_zero + | FP_normal + | FP_subnormal -> + let s = string_of_float f in + Format.fprintf fmt "%s" s; + let s_len = String.length s in + if s.[ s_len - 1 ] = '.' then + Format.fprintf fmt "0" + +let escape_json_string buf s = + for i = 0 to String.length s - 1 do + let c = String.unsafe_get s i in + match c with + | '"' -> Buffer.add_string buf "\\\"" + | '\t' -> Buffer.add_string buf "\\t" + | '\r' -> Buffer.add_string buf "\\r" + | '\b' -> Buffer.add_string buf "\\b" + | '\n' -> Buffer.add_string buf "\\n" + | '\012' -> Buffer.add_string buf "\\f" + | '\\' -> Buffer.add_string buf "\\\\" + (* | '/' -> "\\/" *) (* Forward slash can be escaped + but doesn't have to *) + | '\x00'..'\x1F' (* Control characters that must be escaped *) + | '\x7F' (* DEL *) -> + Printf.bprintf buf "\\u%04X" (int_of_char c) + | _ -> + (* Don't bother detecting or escaping multibyte chars *) + Buffer.add_char buf c + done + +let fquote_json_string fmt s = + let buf = Buffer.create (String.length s) in + escape_json_string buf s; + Format.fprintf fmt "\"%s\"" (Buffer.contents buf) + +let bquote_json_string buf s = + Printf.bprintf buf "\"%a\"" escape_json_string s + +module Compact = +struct + open Format + + let rec fprint_json allow_nan fmt = function + Object o -> + pp_print_string fmt "{"; + fprint_object allow_nan fmt o; + pp_print_string fmt "}" + | Array a -> + pp_print_string fmt "["; + fprint_list allow_nan fmt a; + pp_print_string fmt "]" + | Bool b -> + pp_print_string fmt (if b then "true" else "false") + | Null -> + pp_print_string fmt "null" + | Int i -> pp_print_string fmt (string_of_int i) + | Float f -> pp_print_string fmt (string_of_json_float allow_nan f) + | String s -> fquote_json_string fmt s + + and fprint_list allow_nan fmt = function + [] -> () + | [x] -> fprint_json allow_nan fmt x + | x :: tl -> + fprint_json allow_nan fmt x; + pp_print_string fmt ","; + fprint_list allow_nan fmt tl + + and fprint_object allow_nan fmt = function + [] -> () + | [x] -> fprint_pair allow_nan fmt x + | x :: tl -> + fprint_pair allow_nan fmt x; + pp_print_string fmt ","; + fprint_object allow_nan fmt tl + + and fprint_pair allow_nan fmt (key, x) = + fquote_json_string fmt key; + fprintf fmt ":"; + fprint_json allow_nan fmt x + + (* json does not allow rendering floats with a trailing dot: that is, + 1234. is not allowed, but 1234.0 is ok. here, we add a '0' if + string_of_int result in a trailing dot *) + and string_of_json_float allow_nan f = + let s = string_of_float f in + let s_len = String.length s in + if s.[ s_len - 1 ] = '.' then + s ^ "0" + else + s + + let print ?(allow_nan = false) ?(recursive = false) fmt x = + if not recursive then + Browse.assert_object_or_array x; + fprint_json allow_nan fmt x +end + + +module Fast = +struct + open Printf + open Buffer + + (* Contiguous sequence of non-escaped characters are copied to the buffer + using one call to Buffer.add_substring *) + let rec buf_add_json_escstr1 buf s k1 l = + if k1 < l then ( + let k2 = buf_add_json_escstr2 buf s k1 k1 l in + if k2 > k1 then + Buffer.add_substring buf s k1 (k2 - k1); + if k2 < l then ( + let c = String.unsafe_get s k2 in + ( match c with + | '"' -> Buffer.add_string buf "\\\"" + | '\t' -> Buffer.add_string buf "\\t" + | '\r' -> Buffer.add_string buf "\\r" + | '\b' -> Buffer.add_string buf "\\b" + | '\n' -> Buffer.add_string buf "\\n" + | '\012' -> Buffer.add_string buf "\\f" + | '\\' -> Buffer.add_string buf "\\\\" + (* | '/' -> "\\/" *) (* Forward slash can be escaped + but doesn't have to *) + | '\x00'..'\x1F' (* Control characters that must be escaped *) + | '\x7F' (* DEL *) -> + Printf.bprintf buf "\\u%04X" (int_of_char c) + | _ -> assert false + ); + buf_add_json_escstr1 buf s (k2+1) l + ) + ) + + and buf_add_json_escstr2 buf s k1 k2 l = + if k2 < l then ( + let c = String.unsafe_get s k2 in + match c with + | '"' | '\t' | '\r' | '\b' | '\n' | '\012' | '\\' (*| '/'*) + | '\x00'..'\x1F' | '\x7F' -> k2 + | _ -> buf_add_json_escstr2 buf s k1 (k2+1) l + ) + else + l + + and bquote_json_string buf s = + Buffer.add_char buf '"'; + buf_add_json_escstr1 buf s 0 (String.length s); + Buffer.add_char buf '"' + + let rec bprint_json allow_nan buf = function + Object o -> + add_string buf "{"; + bprint_object allow_nan buf o; + add_string buf "}" + | Array a -> + add_string buf "["; + bprint_list allow_nan buf a; + add_string buf "]" + | Bool b -> + add_string buf (if b then "true" else "false") + | Null -> + add_string buf "null" + | Int i -> add_string buf (string_of_int i) + | Float f -> add_string buf (string_of_json_float allow_nan f) + | String s -> bquote_json_string buf s + + and bprint_list allow_nan buf = function + [] -> () + | [x] -> bprint_json allow_nan buf x + | x :: tl -> + bprint_json allow_nan buf x; + add_string buf ","; + bprint_list allow_nan buf tl + + and bprint_object allow_nan buf = function + [] -> () + | [x] -> bprint_pair allow_nan buf x + | x :: tl -> + bprint_pair allow_nan buf x; + add_string buf ","; + bprint_object allow_nan buf tl + + and bprint_pair allow_nan buf (key, x) = + bquote_json_string buf key; + bprintf buf ":"; + bprint_json allow_nan buf x + + (* json does not allow rendering floats with a trailing dot: that is, + 1234. is not allowed, but 1234.0 is ok. here, we add a '0' if + string_of_int result in a trailing dot *) + and string_of_json_float allow_nan f = + match classify_float f with + FP_nan -> + if allow_nan then "NaN" + else json_error "Not allowed to serialize NaN value" + | FP_infinite -> + if allow_nan then + if f < 0. then "-Infinity" + else "Infinity" + else json_error "Not allowed to serialize infinite value" + | FP_zero + | FP_normal + | FP_subnormal -> + let s = string_of_float f in + let s_len = String.length s in + if s.[ s_len - 1 ] = '.' then + s ^ "0" + else + s + + let print ?(allow_nan = false) ?(recursive = false) buf x = + if not recursive then + Browse.assert_object_or_array x; + bprint_json allow_nan buf x +end + + + +(*** Pretty printing ***) + +module Pretty = +struct + open Format + + (* Printing anything but a value in a key:value pair. + + Opening and closing brackets in such arrays and objects + are aligned vertically if they are not on the same line. + *) + let rec fprint_json allow_nan fmt = function + Object l -> fprint_object allow_nan fmt l + | Array l -> fprint_array allow_nan fmt l + | Bool b -> fprintf fmt "%s" (if b then "true" else "false") + | Null -> fprintf fmt "null" + | Int i -> fprintf fmt "%i" i + | Float f -> fprint_float allow_nan fmt f + | String s -> fquote_json_string fmt s + + (* Printing an array which is not the value in a key:value pair *) + and fprint_array allow_nan fmt = function + [] -> fprintf fmt "[]" + | x :: tl -> + fprintf fmt "@[[@ "; + fprint_json allow_nan fmt x; + List.iter (fun x -> + fprintf fmt ",@ "; + fprint_json allow_nan fmt x) tl; + fprintf fmt "@;<1 -2>]@]" + + (* Printing an object which is not the value in a key:value pair *) + and fprint_object allow_nan fmt = function + [] -> fprintf fmt "{}" + | x :: tl -> + fprintf fmt "@[{@ "; + fprint_pair allow_nan fmt x; + List.iter (fun x -> + fprintf fmt ",@ "; + fprint_pair allow_nan fmt x) tl; + fprintf fmt "@;<1 -2>}@]" + + (* Printing a key:value pair. + + The opening bracket stays on the same line as the key, no matter what, + and the closing bracket is either on the same line + or vertically aligned with the beginning of the key. + *) + and fprint_pair allow_nan fmt (key, x) = + match x with + Object l -> + (match l with + [] -> fprintf fmt "%a: {}" fquote_json_string key + | x :: tl -> + fprintf fmt "@[%a: {@ " fquote_json_string key; + fprint_pair allow_nan fmt x; + List.iter (fun x -> + fprintf fmt ",@ "; + fprint_pair allow_nan fmt x) tl; + fprintf fmt "@;<1 -2>}@]") + | Array l -> + (match l with + [] -> fprintf fmt "%a: []" fquote_json_string key + | x :: tl -> + fprintf fmt "@[%a: [@ " fquote_json_string key; + fprint_json allow_nan fmt x; + List.iter (fun x -> + fprintf fmt ",@ "; + fprint_json allow_nan fmt x) tl; + fprintf fmt "@;<1 -2>]@]") + | _ -> + (* An atom, perhaps a long string that would go to the next line *) + fprintf fmt "@[%a:@;<1 2>%a@]" + fquote_json_string key (fprint_json allow_nan) x + + let print ?(allow_nan = false) ?(recursive = false) fmt x = + if not recursive then + Browse.assert_object_or_array x; + fprint_json allow_nan fmt x +end + + +let string_of_json ?allow_nan ?(compact = false) ?recursive x = + let buf = Buffer.create 2000 in + if compact then + Fast.print ?allow_nan ?recursive buf x + else + (let fmt = Format.formatter_of_buffer buf in + (match recursive with + None + | Some false -> Browse.assert_object_or_array x + | Some true -> () + ); + let allow_nan = match allow_nan with None -> false | Some b -> b in + Pretty.fprint_json allow_nan fmt x; + Format.pp_print_flush fmt ()); + Buffer.contents buf + +let save_json ?allow_nan ?(compact = false) ?recursive file x = + let oc = open_out file in + let print = + if compact then Compact.print + else Pretty.print in + let fmt = Format.formatter_of_out_channel oc in + try + print ?allow_nan ?recursive fmt x; + Format.pp_print_flush fmt (); + close_out oc + with e -> + close_out_noerr oc; + raise e diff --git a/external/jsonwheel/json_io.mli b/external/jsonwheel/json_io.mli new file mode 100644 index 0000000..ab80a36 --- /dev/null +++ b/external/jsonwheel/json_io.mli @@ -0,0 +1,111 @@ +(** Input and output functions for the JSON format + as defined by {{:http://www.json.org/}http://www.json.org/} *) + + +(** [json_of_string s] reads the given JSON string. + + If [allow_comments] is [true], then C++ style comments are allowed, i.e. + [/* blabla possibly on several lines */] or + [// blabla until the end of the line]. Comments are not part of the JSON + specification and are disabled by default. + + If [allow_nan] is [true], then OCaml [nan], [infinity] and [neg_infinity] + float values are represented using their Javascript counterparts + [NaN], [Infinity] and [-Infinity]. + + If [big_int_mode] is [true], then JSON ints that cannot be represented + using OCaml's int type are represented by strings. + This would happen only for ints that are out of the range defined + by [min_int] and [max_int], i.e. \[-1G, +1G\[ on a 32-bit platform. + The default is [false] and a [Json_type.Json_error] exception + is raised if an int is too big. + + If [recursive] is true, then all JSON values are accepted rather + than just arrays and objects as specified by the standard. + The default is [false]. +*) +val json_of_string : + ?allow_comments:bool -> + ?allow_nan:bool -> + ?big_int_mode:bool -> + ?recursive:bool -> + string -> Json_type.t + +(** Same as [Json_io.json_of_string] but the argument is a file + to read from. *) +val load_json : + ?allow_comments:bool -> + ?allow_nan:bool -> + ?big_int_mode:bool -> + ?recursive:bool -> + string -> Json_type.t + +(** Conversion of JSON data to compact text. *) +module Compact : +sig + (** Generic printing function without superfluous space. + See the standard [Format] module + for how to create and use formatters. + + In general, {!Json_io.string_of_json} and + {!Json_io.save_json} are more convenient. + *) + val print : + ?allow_nan: bool -> + ?recursive:bool -> + Format.formatter -> Json_type.t -> unit +end + +(** Conversion of JSON data to compact text, optimized for speed. *) +module Fast : +sig + (** This function is faster than the one provided by the + {!Json_io.Compact} submodule but it is less generic and is subject to + the 16MB size limit of strings on 32-bit architectures. *) + val print : + ?allow_nan: bool -> + ?recursive:bool -> + Buffer.t -> Json_type.t -> unit +end + + +(** Conversion of JSON data to indented text. *) +module Pretty : +sig + (** Generic pretty-printing function. + See the standard [Format] module + for how to create and use formatters. + + In general, {!Json_io.string_of_json} and + {!Json_io.save_json} are more convenient. + *) + val print : + ?allow_nan: bool -> + ?recursive:bool -> + Format.formatter -> Json_type.t -> unit +end + +(** [string_of_json] converts JSON data to a string. + + By default, the output is indented. If the [compact] flag is set to true, + the output will not contain superfluous whitespace and will + be produced faster. + + If [allow_nan] is [true], then OCaml [nan], [infinity] and [neg_infinity] + float values are represented using their Javascript counterparts + [NaN], [Infinity] and [-Infinity]. +*) +val string_of_json : + ?allow_nan: bool -> + ?compact:bool -> + ?recursive:bool -> + Json_type.t -> string + +(** [save_json] works like {!Json_io.string_of_json} but + saves the results directly into the file specified by the + argument of type string. *) +val save_json : + ?allow_nan:bool -> + ?compact:bool -> + ?recursive:bool -> + string -> Json_type.t -> unit diff --git a/external/jsonwheel/json_lexer.ml b/external/jsonwheel/json_lexer.ml new file mode 100644 index 0000000..d4f5446 --- /dev/null +++ b/external/jsonwheel/json_lexer.ml @@ -0,0 +1,542 @@ +# 1 "json_lexer.mll" + + open Printf + open Lexing + + open Json_type + open Json_parser + + let loc lexbuf = (lexbuf.lex_start_p, lexbuf.lex_curr_p) + + (* Detection of the encoding from the 4 first characters of the data *) + let detect_encoding c1 c2 c3 c4 = + match c1, c2, c3, c4 with + '\000', '\000', '\000', _ -> `UTF32BE + | '\000', _, '\000', _ -> `UTF16BE + | _, '\000', '\000', '\000' -> `UTF32LE + | _, '\000', _, '\000' -> `UTF16LE + | _ -> `UTF8 + + let hexval c = + match c with + '0'..'9' -> int_of_char c - int_of_char '0' + | 'a'..'f' -> int_of_char c - int_of_char 'a' + 10 + | 'A'..'F' -> int_of_char c - int_of_char 'A' + 10 + | _ -> assert false + + let make_int big_int_mode s = + try INT (int_of_string s) + with _ -> + if big_int_mode then STRING s + else json_error (s ^ " is too large for OCaml's type int, sorry") + + let utf8_of_point i = + Netconversion2.ustring_of_uchar `Enc_utf8 i + + let custom_error descr lexbuf = + json_error + (sprintf "%s:\n%s" + (string_of_loc (loc lexbuf)) + descr) + + let lexer_error descr lexbuf = + custom_error + (sprintf "%s '%s'" descr (Lexing.lexeme lexbuf)) + lexbuf + + let set_file_name lexbuf name = + lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = name } + + let newline lexbuf = + let pos = lexbuf.lex_curr_p in + lexbuf.lex_curr_p <- { pos with + pos_lnum = pos.pos_lnum + 1; + pos_bol = pos.pos_cnum } + + type param = { + allow_comments : bool; + big_int_mode : bool; + allow_nan : bool + } + +# 63 "json_lexer.ml" +let __ocaml_lex_tables = { + Lexing.lex_base = + "\000\000\235\255\236\255\003\000\238\255\000\000\031\000\241\255\ + \085\000\001\000\000\000\000\000\001\000\000\000\248\255\249\255\ + \250\255\251\255\252\255\253\255\017\000\254\255\001\000\001\000\ + \002\000\247\255\000\000\000\000\003\000\246\255\001\000\004\000\ + \245\255\011\000\244\255\003\000\001\000\003\000\002\000\003\000\ + \000\000\243\255\010\000\020\000\019\000\016\000\022\000\012\000\ + \008\000\242\255\100\000\111\000\121\000\143\000\153\000\163\000\ + \175\000\185\000\002\001\251\255\252\255\037\001\254\255\255\255\ + \035\001\248\255\056\001\250\255\251\255\252\255\253\255\254\255\ + \255\255\111\001\134\001\172\001\249\255\089\000\252\255\253\255\ + \254\255\013\000\255\255"; + Lexing.lex_backtrk = + "\255\255\255\255\255\255\018\000\255\255\015\000\015\000\255\255\ + \020\000\020\000\020\000\020\000\020\000\020\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\020\000\255\255\000\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\016\000\255\255\016\000\255\255\ + \016\000\255\255\255\255\255\255\255\255\002\000\255\255\255\255\ + \255\255\255\255\007\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\003\000\255\255"; + Lexing.lex_default = + "\001\000\000\000\000\000\255\255\000\000\255\255\255\255\000\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\000\000\000\000\ + \000\000\000\000\000\000\000\000\255\255\000\000\022\000\255\255\ + \255\255\000\000\255\255\255\255\255\255\000\000\255\255\255\255\ + \000\000\255\255\000\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\061\000\000\000\000\000\061\000\000\000\000\000\ + \065\000\000\000\255\255\000\000\000\000\000\000\000\000\000\000\ + \000\000\255\255\255\255\255\255\000\000\078\000\000\000\000\000\ + \000\000\255\255\000\000"; + Lexing.lex_trans = + "\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\003\000\004\000\255\255\003\000\003\000\000\000\000\000\ + \003\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \003\000\000\000\007\000\003\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\015\000\008\000\051\000\020\000\ + \005\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\006\000\014\000\021\000\082\000\000\000\000\000\000\000\ + \022\000\000\000\000\000\000\000\000\000\050\000\000\000\000\000\ + \000\000\009\000\000\000\000\000\000\000\051\000\010\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\034\000\000\000\017\000\000\000\016\000\000\000\000\000\ + \000\000\033\000\026\000\079\000\050\000\050\000\012\000\025\000\ + \029\000\036\000\037\000\039\000\027\000\031\000\011\000\035\000\ + \032\000\038\000\023\000\028\000\013\000\030\000\024\000\040\000\ + \043\000\041\000\044\000\019\000\045\000\018\000\046\000\047\000\ + \048\000\049\000\000\000\081\000\050\000\005\000\006\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\057\000\ + \000\000\057\000\000\000\000\000\056\000\056\000\056\000\056\000\ + \056\000\056\000\056\000\056\000\056\000\056\000\042\000\052\000\ + \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ + \052\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ + \052\000\052\000\052\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\055\000\000\000\055\000\000\000\053\000\054\000\ + \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ + \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ + \054\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ + \054\000\054\000\054\000\054\000\054\000\000\000\053\000\056\000\ + \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ + \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ + \056\000\056\000\056\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \002\000\255\255\060\000\060\000\060\000\060\000\060\000\060\000\ + \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ + \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ + \060\000\060\000\060\000\060\000\060\000\060\000\060\000\060\000\ + \060\000\060\000\000\000\000\000\063\000\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\072\000\000\000\255\255\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\072\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\080\000\000\000\000\000\000\000\000\000\062\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ + \073\000\073\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\073\000\073\000\073\000\073\000\073\000\073\000\072\000\ + \000\000\255\255\000\000\000\000\000\000\071\000\000\000\000\000\ + \000\000\070\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\069\000\000\000\000\000\000\000\068\000\000\000\067\000\ + \066\000\073\000\073\000\073\000\073\000\073\000\073\000\074\000\ + \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ + \074\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \074\000\074\000\074\000\074\000\074\000\074\000\075\000\075\000\ + \075\000\075\000\075\000\075\000\075\000\075\000\075\000\075\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\075\000\ + \075\000\075\000\075\000\075\000\075\000\000\000\000\000\000\000\ + \074\000\074\000\074\000\074\000\074\000\074\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\076\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\076\000\076\000\076\000\000\000\075\000\ + \075\000\075\000\075\000\075\000\075\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\059\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\076\000\076\000\076\000\ + \076\000\076\000\076\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\255\255\000\000\255\255\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\000\000\000\000"; + Lexing.lex_check = + "\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\000\000\000\000\022\000\003\000\000\000\255\255\255\255\ + \003\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \000\000\255\255\000\000\003\000\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\000\000\000\000\005\000\000\000\ + \000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ + \000\000\000\000\000\000\020\000\081\000\255\255\255\255\255\255\ + \020\000\255\255\255\255\255\255\255\255\005\000\255\255\255\255\ + \255\255\000\000\255\255\255\255\255\255\006\000\000\000\006\000\ + \006\000\006\000\006\000\006\000\006\000\006\000\006\000\006\000\ + \006\000\033\000\255\255\000\000\255\255\000\000\255\255\255\255\ + \255\255\010\000\012\000\077\000\006\000\005\000\000\000\024\000\ + \028\000\035\000\036\000\038\000\026\000\030\000\000\000\009\000\ + \031\000\037\000\013\000\027\000\000\000\011\000\023\000\039\000\ + \042\000\040\000\043\000\000\000\044\000\000\000\045\000\046\000\ + \047\000\048\000\255\255\077\000\006\000\008\000\008\000\008\000\ + \008\000\008\000\008\000\008\000\008\000\008\000\008\000\050\000\ + \255\255\050\000\255\255\255\255\050\000\050\000\050\000\050\000\ + \050\000\050\000\050\000\050\000\050\000\050\000\008\000\051\000\ + \051\000\051\000\051\000\051\000\051\000\051\000\051\000\051\000\ + \051\000\052\000\052\000\052\000\052\000\052\000\052\000\052\000\ + \052\000\052\000\052\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\053\000\255\255\053\000\255\255\052\000\053\000\ + \053\000\053\000\053\000\053\000\053\000\053\000\053\000\053\000\ + \053\000\054\000\054\000\054\000\054\000\054\000\054\000\054\000\ + \054\000\054\000\054\000\055\000\055\000\055\000\055\000\055\000\ + \055\000\055\000\055\000\055\000\055\000\255\255\052\000\056\000\ + \056\000\056\000\056\000\056\000\056\000\056\000\056\000\056\000\ + \056\000\057\000\057\000\057\000\057\000\057\000\057\000\057\000\ + \057\000\057\000\057\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \000\000\022\000\058\000\058\000\058\000\058\000\058\000\058\000\ + \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ + \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ + \058\000\058\000\058\000\058\000\058\000\058\000\058\000\058\000\ + \058\000\058\000\255\255\255\255\058\000\061\000\061\000\061\000\ + \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ + \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ + \061\000\061\000\061\000\061\000\061\000\061\000\061\000\061\000\ + \061\000\061\000\061\000\061\000\061\000\064\000\255\255\061\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\064\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\077\000\255\255\255\255\255\255\255\255\058\000\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \066\000\066\000\066\000\066\000\066\000\066\000\066\000\066\000\ + \066\000\066\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\066\000\066\000\066\000\066\000\066\000\066\000\064\000\ + \255\255\061\000\255\255\255\255\255\255\064\000\255\255\255\255\ + \255\255\064\000\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\064\000\255\255\255\255\255\255\064\000\255\255\064\000\ + \064\000\066\000\066\000\066\000\066\000\066\000\066\000\073\000\ + \073\000\073\000\073\000\073\000\073\000\073\000\073\000\073\000\ + \073\000\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \073\000\073\000\073\000\073\000\073\000\073\000\074\000\074\000\ + \074\000\074\000\074\000\074\000\074\000\074\000\074\000\074\000\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\074\000\ + \074\000\074\000\074\000\074\000\074\000\255\255\255\255\255\255\ + \073\000\073\000\073\000\073\000\073\000\073\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\075\000\075\000\075\000\075\000\ + \075\000\075\000\075\000\075\000\075\000\075\000\255\255\074\000\ + \074\000\074\000\074\000\074\000\074\000\075\000\075\000\075\000\ + \075\000\075\000\075\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\058\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\075\000\075\000\075\000\ + \075\000\075\000\075\000\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\064\000\255\255\061\000\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ + \255\255\255\255\255\255\255\255\255\255"; + Lexing.lex_base_code = + ""; + Lexing.lex_backtrk_code = + ""; + Lexing.lex_default_code = + ""; + Lexing.lex_trans_code = + ""; + Lexing.lex_check_code = + ""; + Lexing.lex_code = + ""; +} + +let rec token p lexbuf = + __ocaml_lex_token_rec p lexbuf 0 +and __ocaml_lex_token_rec p lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 79 "json_lexer.mll" + ( if p.allow_comments then + token p lexbuf + else lexer_error "Comments are not allowed: " lexbuf ) +# 298 "json_lexer.ml" + + | 1 -> +# 82 "json_lexer.mll" + ( if p.allow_comments then + (comment lexbuf; + token p lexbuf) + else lexer_error "Comments are not allowed: " lexbuf ) +# 306 "json_lexer.ml" + + | 2 -> +# 86 "json_lexer.mll" + ( OBJSTART ) +# 311 "json_lexer.ml" + + | 3 -> +# 87 "json_lexer.mll" + ( OBJEND ) +# 316 "json_lexer.ml" + + | 4 -> +# 88 "json_lexer.mll" + ( ARSTART ) +# 321 "json_lexer.ml" + + | 5 -> +# 89 "json_lexer.mll" + ( AREND ) +# 326 "json_lexer.ml" + + | 6 -> +# 90 "json_lexer.mll" + ( COMMA ) +# 331 "json_lexer.ml" + + | 7 -> +# 91 "json_lexer.mll" + ( COLON ) +# 336 "json_lexer.ml" + + | 8 -> +# 92 "json_lexer.mll" + ( BOOL true ) +# 341 "json_lexer.ml" + + | 9 -> +# 93 "json_lexer.mll" + ( BOOL false ) +# 346 "json_lexer.ml" + + | 10 -> +# 94 "json_lexer.mll" + ( NULL ) +# 351 "json_lexer.ml" + + | 11 -> +# 95 "json_lexer.mll" + ( if p.allow_nan then FLOAT nan + else lexer_error "NaN values are not allowed: " lexbuf ) +# 357 "json_lexer.ml" + + | 12 -> +# 97 "json_lexer.mll" + ( if p.allow_nan then FLOAT infinity + else lexer_error "Infinite values are not allowed: " lexbuf ) +# 363 "json_lexer.ml" + + | 13 -> +# 99 "json_lexer.mll" + ( if p.allow_nan then FLOAT neg_infinity + else lexer_error "Infinite values are not allowed: " lexbuf ) +# 369 "json_lexer.ml" + + | 14 -> +# 101 "json_lexer.mll" + ( STRING (string [] lexbuf) ) +# 374 "json_lexer.ml" + + | 15 -> +# 102 "json_lexer.mll" + ( make_int p.big_int_mode (lexeme lexbuf) ) +# 379 "json_lexer.ml" + + | 16 -> +# 103 "json_lexer.mll" + ( FLOAT (float_of_string (lexeme lexbuf)) ) +# 384 "json_lexer.ml" + + | 17 -> +# 104 "json_lexer.mll" + ( newline lexbuf; token p lexbuf ) +# 389 "json_lexer.ml" + + | 18 -> +# 105 "json_lexer.mll" + ( token p lexbuf ) +# 394 "json_lexer.ml" + + | 19 -> +# 106 "json_lexer.mll" + ( EOF ) +# 399 "json_lexer.ml" + + | 20 -> +# 107 "json_lexer.mll" + ( lexer_error "Invalid token" lexbuf ) +# 404 "json_lexer.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec p lexbuf __ocaml_lex_state + +and string l lexbuf = + __ocaml_lex_string_rec l lexbuf 58 +and __ocaml_lex_string_rec l lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 111 "json_lexer.mll" + ( String.concat "" (List.rev l) ) +# 415 "json_lexer.ml" + + | 1 -> +# 112 "json_lexer.mll" + ( let s = escaped_char lexbuf in + string (s :: l) lexbuf ) +# 421 "json_lexer.ml" + + | 2 -> +# 114 "json_lexer.mll" + ( let s = lexeme lexbuf in + string (s :: l) lexbuf ) +# 427 "json_lexer.ml" + + | 3 -> +let +# 116 "json_lexer.mll" + c +# 433 "json_lexer.ml" += Lexing.sub_lexeme_char lexbuf lexbuf.Lexing.lex_start_pos in +# 116 "json_lexer.mll" + ( custom_error + (sprintf "Unescaped control character \\u%04X or \ + unterminated string" (int_of_char c)) + lexbuf ) +# 440 "json_lexer.ml" + + | 4 -> +# 120 "json_lexer.mll" + ( custom_error "Unterminated string" lexbuf ) +# 445 "json_lexer.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_string_rec l lexbuf __ocaml_lex_state + +and escaped_char lexbuf = + __ocaml_lex_escaped_char_rec lexbuf 64 +and __ocaml_lex_escaped_char_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 126 "json_lexer.mll" + ( lexeme lexbuf ) +# 456 "json_lexer.ml" + + | 1 -> +# 127 "json_lexer.mll" + ( "\b" ) +# 461 "json_lexer.ml" + + | 2 -> +# 128 "json_lexer.mll" + ( "\012" ) +# 466 "json_lexer.ml" + + | 3 -> +# 129 "json_lexer.mll" + ( "\n" ) +# 471 "json_lexer.ml" + + | 4 -> +# 130 "json_lexer.mll" + ( "\r" ) +# 476 "json_lexer.ml" + + | 5 -> +# 131 "json_lexer.mll" + ( "\t" ) +# 481 "json_lexer.ml" + + | 6 -> +let +# 132 "json_lexer.mll" + x +# 487 "json_lexer.ml" += Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) (lexbuf.Lexing.lex_start_pos + 5) in +# 132 "json_lexer.mll" + ( let i = 0x1000 * hexval x.[0] + + 0x100 * hexval x.[1] + + 0x10 * hexval x.[2] + + hexval x.[3] in + utf8_of_point i ) +# 495 "json_lexer.ml" + + | 7 -> +# 137 "json_lexer.mll" + ( lexer_error "Invalid escape sequence" lexbuf ) +# 500 "json_lexer.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_escaped_char_rec lexbuf __ocaml_lex_state + +and comment lexbuf = + __ocaml_lex_comment_rec lexbuf 77 +and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = + match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with + | 0 -> +# 140 "json_lexer.mll" + ( () ) +# 511 "json_lexer.ml" + + | 1 -> +# 141 "json_lexer.mll" + ( lexer_error "Unterminated comment" lexbuf ) +# 516 "json_lexer.ml" + + | 2 -> +# 142 "json_lexer.mll" + ( newline lexbuf; comment lexbuf ) +# 521 "json_lexer.ml" + + | 3 -> +# 143 "json_lexer.mll" + ( comment lexbuf ) +# 526 "json_lexer.ml" + + | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state + +;; + +# 145 "json_lexer.mll" + + let make_param + ?(allow_comments = false) + ?(allow_nan = false) + ?(big_int_mode = false) + () = + { allow_comments = allow_comments; + big_int_mode = big_int_mode; + allow_nan = allow_nan } + +# 543 "json_lexer.ml" diff --git a/external/jsonwheel/json_out.ml b/external/jsonwheel/json_out.ml new file mode 100644 index 0000000..5a6c80f --- /dev/null +++ b/external/jsonwheel/json_out.ml @@ -0,0 +1,163 @@ +type t = Json_type.t +open Json_type + +(* pad: copy paste of printing and pretty printing section of json_io.ml *) + +(*** Printing ***) + +(* JSON does not allow rendering floats with a trailing dot: that is, + 1234. is not allowed, but 1234.0 is ok. here, we add a '0' if + string_of_int result in a trailing dot *) +let fprint_float allow_nan fmt f = + match classify_float f with + FP_nan -> + if allow_nan then Format.fprintf fmt "NaN" + else json_error "Not allowed to serialize NaN value" + | FP_infinite -> + if allow_nan then + if f < 0. then Format.fprintf fmt "-Infinity" + else Format.fprintf fmt "Infinity" + else json_error "Not allowed to serialize infinite value" + | FP_zero + | FP_normal + | FP_subnormal -> + let s = string_of_float f in + Format.fprintf fmt "%s" s; + let s_len = String.length s in + if s.[ s_len - 1 ] = '.' then + Format.fprintf fmt "0" + +let escape_json_string buf s = + for i = 0 to String.length s - 1 do + let c = String.unsafe_get s i in + match c with + | '"' -> Buffer.add_string buf "\\\"" + | '\t' -> Buffer.add_string buf "\\t" + | '\r' -> Buffer.add_string buf "\\r" + | '\b' -> Buffer.add_string buf "\\b" + | '\n' -> Buffer.add_string buf "\\n" + | '\012' -> Buffer.add_string buf "\\f" + | '\\' -> Buffer.add_string buf "\\\\" + (* | '/' -> "\\/" *) (* Forward slash can be escaped + but doesn't have to *) + | '\x00'..'\x1F' (* Control characters that must be escaped *) + | '\x7F' (* DEL *) -> + Printf.bprintf buf "\\u%04X" (int_of_char c) + | _ -> + (* Don't bother detecting or escaping multibyte chars *) + Buffer.add_char buf c + done + +let fquote_json_string fmt s = + let buf = Buffer.create (String.length s) in + escape_json_string buf s; + Format.fprintf fmt "\"%s\"" (Buffer.contents buf) + +let bquote_json_string buf s = + Printf.bprintf buf "\"%a\"" escape_json_string s + +(*** Pretty printing ***) + +module Pretty = +struct + open Format + + (* Printing anything but a value in a key:value pair. + + Opening and closing brackets in such arrays and objects + are aligned vertically if they are not on the same line. + *) + let rec fprint_json allow_nan fmt = function + Object l -> fprint_object allow_nan fmt l + | Array l -> fprint_array allow_nan fmt l + | Bool b -> fprintf fmt "%s" (if b then "true" else "false") + | Null -> fprintf fmt "null" + | Int i -> fprintf fmt "%i" i + | Float f -> fprint_float allow_nan fmt f + | String s -> fquote_json_string fmt s + + (* Printing an array which is not the value in a key:value pair *) + and fprint_array allow_nan fmt = function + [] -> fprintf fmt "[]" + | x :: tl -> + fprintf fmt "@[[@ "; + fprint_json allow_nan fmt x; + List.iter (fun x -> + fprintf fmt ",@ "; + fprint_json allow_nan fmt x) tl; + fprintf fmt "@;<1 -2>]@]" + + (* Printing an object which is not the value in a key:value pair *) + and fprint_object allow_nan fmt = function + [] -> fprintf fmt "{}" + | x :: tl -> + fprintf fmt "@[{@ "; + fprint_pair allow_nan fmt x; + List.iter (fun x -> + fprintf fmt ",@ "; + fprint_pair allow_nan fmt x) tl; + fprintf fmt "@;<1 -2>}@]" + + (* Printing a key:value pair. + + The opening bracket stays on the same line as the key, no matter what, + and the closing bracket is either on the same line + or vertically aligned with the beginning of the key. + *) + and fprint_pair allow_nan fmt (key, x) = + match x with + Object l -> + (match l with + [] -> fprintf fmt "%a: {}" fquote_json_string key + | x :: tl -> + fprintf fmt "@[%a: {@ " fquote_json_string key; + fprint_pair allow_nan fmt x; + List.iter (fun x -> + fprintf fmt ",@ "; + fprint_pair allow_nan fmt x) tl; + fprintf fmt "@;<1 -2>}@]") + | Array l -> + (match l with + [] -> fprintf fmt "%a: []" fquote_json_string key + | x :: tl -> + fprintf fmt "@[%a: [@ " fquote_json_string key; + fprint_json allow_nan fmt x; + List.iter (fun x -> + fprintf fmt ",@ "; + fprint_json allow_nan fmt x) tl; + fprintf fmt "@;<1 -2>]@]") + | _ -> + (* An atom, perhaps a long string that would go to the next line *) + fprintf fmt "@[%a:@;<1 2>%a@]" + fquote_json_string key (fprint_json allow_nan) x + + let print ?(allow_nan = false) ?(recursive = false) fmt x = + if not recursive then + Browse.assert_object_or_array x; + fprint_json allow_nan fmt x +end + + +let string_of_json ?allow_nan (*?(compact = false) ?recursive *) x = + let buf = Buffer.create 2000 in + (* + if compact then + Fast.print ?allow_nan ?recursive buf x + else + (let fmt = Format.formatter_of_buffer buf in + (match recursive with + None + | Some false -> Browse.assert_object_or_array x + | Some true -> () + ); + let allow_nan = match allow_nan with None -> false | Some b -> b in + Pretty.fprint_json allow_nan fmt x; + Format.pp_print_flush fmt ()); + *) + let fmt = Format.formatter_of_buffer buf in + let allow_nan = match allow_nan with None -> false | Some b -> b in + Pretty.fprint_json allow_nan fmt x; + Format.pp_print_flush fmt (); + + Buffer.contents buf + diff --git a/external/jsonwheel/json_parser.ml b/external/jsonwheel/json_parser.ml new file mode 100644 index 0000000..9764380 --- /dev/null +++ b/external/jsonwheel/json_parser.ml @@ -0,0 +1,429 @@ +type token = + | STRING of (string) + | INT of (int) + | FLOAT of (float) + | BOOL of (bool) + | OBJSTART + | OBJEND + | ARSTART + | AREND + | NULL + | COMMA + | COLON + | EOF + +open Parsing;; +# 2 "json_parser.mly" + (* + Notes about error messages and error locations in ocamlyacc: + + 1) There is a predefined "error" symbol which can be used as a catch-all, + in order to get the location of the token that shouldn't be there. + + 2) Additional rules that match common errors are added, so that when + they are matched, a nice, handcrafted error message is produced. + + 3) Token locations are retrieved using functions from the Parsing + module, which relies on a global state. If you want your error locations + to be reliable, don't run two ocamlyacc parsers simultaneously. + + + In the end, the error messages are nicer than the ones that a camlp4 + parser (extensible grammar) would produce because we write them + manually. However camlp4's messages are all automatic, + i.e. they tell you which tokens were expected at a given location. + + For the file/line/char locations to be correct, + the lexbuf must be adjusted by the lexer when the file name + changes or a new line is encountered. This is not performed automatically + by ocamllex, see file json_lexer.mll. + *) + + open Printf + open Json_type + + let rhs_loc n = (Parsing.rhs_start_pos n, Parsing.rhs_end_pos n) + + let unclosed opening_name opening_num closing_name closing_num = + let msg = + sprintf "%s:\nSyntax error: '%s' expected.\n\ + %s:\nThis '%s' might be unmatched." + (string_of_loc (rhs_loc closing_num)) closing_name + (string_of_loc (rhs_loc opening_num)) opening_name in + json_error msg + + let syntax_error s num = + let msg = sprintf "%s:\n%s" (string_of_loc (rhs_loc num)) s in + json_error msg + +# 60 "json_parser.ml" +let yytransl_const = [| + 261 (* OBJSTART *); + 262 (* OBJEND *); + 263 (* ARSTART *); + 264 (* AREND *); + 265 (* NULL *); + 266 (* COMMA *); + 267 (* COLON *); + 0 (* EOF *); + 0|] + +let yytransl_block = [| + 257 (* STRING *); + 258 (* INT *); + 259 (* FLOAT *); + 260 (* BOOL *); + 0|] + +let yylhs = "\255\255\ +\001\000\001\000\001\000\001\000\002\000\002\000\002\000\002\000\ +\002\000\002\000\002\000\002\000\002\000\002\000\002\000\002\000\ +\002\000\002\000\002\000\003\000\003\000\003\000\003\000\004\000\ +\004\000\004\000\004\000\000\000" + +let yylen = "\002\000\ +\002\000\002\000\001\000\001\000\003\000\002\000\003\000\003\000\ +\002\000\003\000\002\000\003\000\003\000\002\000\001\000\001\000\ +\001\000\001\000\001\000\005\000\005\000\004\000\003\000\003\000\ +\003\000\002\000\001\000\002\000" + +let yydefred = "\000\000\ +\000\000\000\000\004\000\015\000\018\000\019\000\016\000\000\000\ +\000\000\017\000\003\000\028\000\000\000\009\000\000\000\006\000\ +\000\000\014\000\011\000\000\000\000\000\002\000\001\000\000\000\ +\008\000\005\000\007\000\000\000\026\000\013\000\010\000\012\000\ +\000\000\025\000\024\000\022\000\000\000\021\000\020\000" + +let yydgoto = "\002\000\ +\012\000\020\000\017\000\021\000" + +let yysindex = "\003\000\ +\001\000\000\000\000\000\000\000\000\000\000\000\000\000\002\255\ +\024\255\000\000\000\000\000\000\011\000\000\000\251\254\000\000\ +\012\000\000\000\000\000\033\255\007\000\000\000\000\000\052\255\ +\000\000\000\000\000\000\043\255\000\000\000\000\000\000\000\000\ +\004\255\000\000\000\000\000\000\009\255\000\000\000\000" + +let yyrindex = "\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\009\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\013\000\000\000\000\000\000\000\000\000\000\000\000\000" + +let yygindex = "\000\000\ +\000\000\255\255\235\255\245\255" + +let yytablesize = 275 +let yytable = "\013\000\ +\011\000\014\000\015\000\001\000\036\000\024\000\032\000\016\000\ +\027\000\015\000\023\000\027\000\023\000\037\000\038\000\039\000\ +\035\000\000\000\029\000\000\000\000\000\000\000\033\000\018\000\ +\004\000\005\000\006\000\007\000\008\000\000\000\009\000\019\000\ +\010\000\004\000\005\000\006\000\007\000\008\000\000\000\009\000\ +\000\000\010\000\028\000\004\000\005\000\006\000\007\000\008\000\ +\000\000\009\000\034\000\010\000\004\000\005\000\006\000\007\000\ +\008\000\000\000\009\000\000\000\010\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\000\ +\003\000\004\000\005\000\006\000\007\000\008\000\030\000\009\000\ +\027\000\010\000\022\000\025\000\023\000\000\000\031\000\000\000\ +\027\000\026\000\023\000" + +let yycheck = "\001\000\ +\000\000\000\001\001\001\001\000\001\001\011\001\000\000\006\001\ +\000\000\001\001\000\000\000\000\000\000\010\001\006\001\037\000\ +\028\000\255\255\020\000\255\255\255\255\255\255\024\000\000\001\ +\001\001\002\001\003\001\004\001\005\001\255\255\007\001\008\001\ +\009\001\001\001\002\001\003\001\004\001\005\001\255\255\007\001\ +\255\255\009\001\010\001\001\001\002\001\003\001\004\001\005\001\ +\255\255\007\001\008\001\009\001\001\001\002\001\003\001\004\001\ +\005\001\255\255\007\001\255\255\009\001\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\255\ +\000\001\001\001\002\001\003\001\004\001\005\001\000\001\007\001\ +\000\001\009\001\000\001\000\001\000\001\255\255\008\001\255\255\ +\008\001\006\001\006\001" + +let yynames_const = "\ + OBJSTART\000\ + OBJEND\000\ + ARSTART\000\ + AREND\000\ + NULL\000\ + COMMA\000\ + COLON\000\ + EOF\000\ + " + +let yynames_block = "\ + STRING\000\ + INT\000\ + FLOAT\000\ + BOOL\000\ + " + +let yyact = [| + (fun _ -> failwith "parser") +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 1 : 'value) in + Obj.repr( +# 55 "json_parser.mly" + ( _1 ) +# 218 "json_parser.ml" + : Json_type.t)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 1 : 'value) in + Obj.repr( +# 56 "json_parser.mly" + ( syntax_error "Junk after end of data" 2 ) +# 225 "json_parser.ml" + : Json_type.t)) +; (fun __caml_parser_env -> + Obj.repr( +# 57 "json_parser.mly" + ( syntax_error "Empty data" 1 ) +# 231 "json_parser.ml" + : Json_type.t)) +; (fun __caml_parser_env -> + Obj.repr( +# 58 "json_parser.mly" + ( syntax_error "Syntax error" 1 ) +# 237 "json_parser.ml" + : Json_type.t)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pair_list) in + Obj.repr( +# 61 "json_parser.mly" + ( Object _2 ) +# 244 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + Obj.repr( +# 62 "json_parser.mly" + ( Object [] ) +# 250 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pair_list) in + Obj.repr( +# 63 "json_parser.mly" + ( unclosed "{" 1 "}" 3 ) +# 257 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'pair_list) in + Obj.repr( +# 64 "json_parser.mly" + ( unclosed "{" 1 "}" 3 ) +# 264 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + Obj.repr( +# 65 "json_parser.mly" + ( syntax_error + "Expecting a comma-separated sequence \ + of string:value pairs" 2 ) +# 272 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'value_list) in + Obj.repr( +# 68 "json_parser.mly" + ( Array _2 ) +# 279 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + Obj.repr( +# 69 "json_parser.mly" + ( Array [] ) +# 285 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'value_list) in + Obj.repr( +# 70 "json_parser.mly" + ( unclosed "[" 1 "]" 3 ) +# 292 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _2 = (Parsing.peek_val __caml_parser_env 1 : 'value_list) in + Obj.repr( +# 71 "json_parser.mly" + ( unclosed "[" 1 "]" 3 ) +# 299 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + Obj.repr( +# 72 "json_parser.mly" + ( syntax_error + "Expecting a comma-separated sequence \ + of values" 2 ) +# 307 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : string) in + Obj.repr( +# 75 "json_parser.mly" + ( String _1 ) +# 314 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : bool) in + Obj.repr( +# 76 "json_parser.mly" + ( Bool _1 ) +# 321 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + Obj.repr( +# 77 "json_parser.mly" + ( Null ) +# 327 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : int) in + Obj.repr( +# 78 "json_parser.mly" + ( Int _1 ) +# 334 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : float) in + Obj.repr( +# 79 "json_parser.mly" + ( Float _1 ) +# 341 "json_parser.ml" + : 'value)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in + let _3 = (Parsing.peek_val __caml_parser_env 2 : 'value) in + let _5 = (Parsing.peek_val __caml_parser_env 0 : 'pair_list) in + Obj.repr( +# 82 "json_parser.mly" + ( (_1, _3) :: _5 ) +# 350 "json_parser.ml" + : 'pair_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 4 : string) in + let _3 = (Parsing.peek_val __caml_parser_env 2 : 'value) in + Obj.repr( +# 84 "json_parser.mly" + ( syntax_error + "End-of-object commas are illegal" 4 ) +# 359 "json_parser.ml" + : 'pair_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 3 : string) in + let _3 = (Parsing.peek_val __caml_parser_env 1 : 'value) in + let _4 = (Parsing.peek_val __caml_parser_env 0 : string) in + Obj.repr( +# 86 "json_parser.mly" + ( syntax_error "Missing ','" 4 ) +# 368 "json_parser.ml" + : 'pair_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 2 : string) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : 'value) in + Obj.repr( +# 87 "json_parser.mly" + ( [ (_1, _3) ] ) +# 376 "json_parser.ml" + : 'pair_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 2 : 'value) in + let _3 = (Parsing.peek_val __caml_parser_env 0 : 'value_list) in + Obj.repr( +# 90 "json_parser.mly" + ( _1 :: _3 ) +# 384 "json_parser.ml" + : 'value_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 2 : 'value) in + Obj.repr( +# 91 "json_parser.mly" + ( syntax_error + "End-of-array commas are illegal" 2 ) +# 392 "json_parser.ml" + : 'value_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 1 : 'value) in + let _2 = (Parsing.peek_val __caml_parser_env 0 : 'value) in + Obj.repr( +# 93 "json_parser.mly" + ( syntax_error "Missing ',' before this value" 2 ) +# 400 "json_parser.ml" + : 'value_list)) +; (fun __caml_parser_env -> + let _1 = (Parsing.peek_val __caml_parser_env 0 : 'value) in + Obj.repr( +# 94 "json_parser.mly" + ( [ _1 ] ) +# 407 "json_parser.ml" + : 'value_list)) +(* Entry main *) +; (fun __caml_parser_env -> raise (Parsing.YYexit (Parsing.peek_val __caml_parser_env 0))) +|] +let yytables = + { Parsing.actions=yyact; + Parsing.transl_const=yytransl_const; + Parsing.transl_block=yytransl_block; + Parsing.lhs=yylhs; + Parsing.len=yylen; + Parsing.defred=yydefred; + Parsing.dgoto=yydgoto; + Parsing.sindex=yysindex; + Parsing.rindex=yyrindex; + Parsing.gindex=yygindex; + Parsing.tablesize=yytablesize; + Parsing.table=yytable; + Parsing.check=yycheck; + Parsing.error_function=parse_error; + Parsing.names_const=yynames_const; + Parsing.names_block=yynames_block } +let main (lexfun : Lexing.lexbuf -> token) (lexbuf : Lexing.lexbuf) = + (Parsing.yyparse yytables 1 lexfun lexbuf : Json_type.t) diff --git a/external/jsonwheel/json_parser.mli b/external/jsonwheel/json_parser.mli new file mode 100644 index 0000000..1c515dc --- /dev/null +++ b/external/jsonwheel/json_parser.mli @@ -0,0 +1,16 @@ +type token = + | STRING of (string) + | INT of (int) + | FLOAT of (float) + | BOOL of (bool) + | OBJSTART + | OBJEND + | ARSTART + | AREND + | NULL + | COMMA + | COLON + | EOF + +val main : + (Lexing.lexbuf -> token) -> Lexing.lexbuf -> Json_type.t diff --git a/external/jsonwheel/json_type.ml b/external/jsonwheel/json_type.ml new file mode 100644 index 0000000..e38de56 --- /dev/null +++ b/external/jsonwheel/json_type.ml @@ -0,0 +1,153 @@ +open Printf +open Lexing + +type json_type = + | Object of (string * json_type) list + | Array of json_type list + + | String of string + | Int of int + | Float of float + | Bool of bool + + | Null + +type t = json_type + +exception Json_error of string + +let json_error s = raise (Json_error s) + + +module Browse = +struct + + let make_table l = + let tbl = Hashtbl.create (List.length l) in + List.iter (fun (key, data) -> Hashtbl.add tbl key data) l; + tbl + + let field tbl x = + match Hashtbl.find_all tbl x with + [y] -> y + | [] -> json_error ("Missing field " ^ x) + | _ -> json_error ("Only one field " ^ x ^ " is expected") + + let fieldx tbl x = + match Hashtbl.find_all tbl x with + [y] -> y + | [] -> Null + | _ -> json_error ("At most one field " ^ x ^ " is expected") + + let optfield tbl x = + match Hashtbl.find_all tbl x with + [y] -> Some y + | [] -> None + | _ -> json_error ("At most one field " ^ x ^ " is expected") + + let optfieldx tbl x = + match Hashtbl.find_all tbl x with + [y] -> + if y = Null then None + else Some y + | [] -> None + | _ -> json_error ("At most one field " ^ x ^ " is expected") + + let describe = function + Bool true -> "true" + | Bool false -> "false" + | Int i -> string_of_int i + | Float x -> string_of_float x + | String s -> sprintf "%S" s + | Object _ -> "an object" + | Array _ -> "an array" + | Null -> "null" + + let type_mismatch expected x = + let descr = describe x in + json_error (sprintf "Expecting %s, not %s" expected descr) + + let is_null x = x = Null + let is_defined x = x <> Null + + let null = function + Null -> () + | x -> type_mismatch "a null value" x + + let string = function + String s -> s + | x -> type_mismatch "a string" x + + let bool = function + Bool x -> x + | x -> type_mismatch "a bool" x + + let number = function + Float x -> x + | Int i -> Pervasives.float i + | x -> type_mismatch "a number" x + + let int = function + Int x -> x + | x -> type_mismatch "an int" x + + let float = function + Float x -> x + | x -> type_mismatch "a float" x + + let array = function + Array x -> x + | x -> type_mismatch "an array" x + + let objekt = function + Object x -> x + | x -> type_mismatch "an object" x + + let list f x = List.map f (array x) + + let option = function + Null -> None + | x -> Some x + + let optional f = function + Null -> None + | x -> Some (f x) + + let assert_object_or_array x = + match x with + Object _ + | Array _ -> () + | _ -> type_mismatch "an array or an object" x +end + +module Build = +struct + let null = Null + let bool x = Bool x + let int x = Int x + let float x = Float x + let string x = String x + let objekt l = Object l + let array l = Array l + + let list f l = Array (List.map f l) + + let option = function + None -> Null + | Some x -> x + + let optional f = function + None -> Null + | Some x -> f x +end + +(* pad: *) +let json_of_list of_a xs = Array(List.map of_a xs) + +let string_of_loc (pos1, pos2) = + let line1 = pos1.pos_lnum + and start1 = pos1.pos_bol in + Printf.sprintf "File %S, line %i, characters %i-%i" + pos1.pos_fname line1 + (pos1.pos_cnum - start1) + (pos2.pos_cnum - start1) diff --git a/external/jsonwheel/json_type.mli b/external/jsonwheel/json_type.mli new file mode 100644 index 0000000..63e46f1 --- /dev/null +++ b/external/jsonwheel/json_type.mli @@ -0,0 +1,224 @@ +(** OCaml representation of JSON data *) + +(** A [json_type] is a boolean, integer, real, string, null. It can + also be lists [Array] or string-keyed maps [Object] of + [json_type]'s. The JSON payload can only be an [Object] or [Array]. + + This type is used by the parsing and printing functions from the + {!Json_io} module. Typically, a program would convert such data into + a specialized type that uses records, etc. For the purpose of converting + from and to other types, two submodules are provided: {!Json_type.Browse} + and {!Json_type.Build}. + They are meant to be opened using either [open Json_type.Browse] + or [open Json_type.Build]. They provided simple functions for converting + JSON data. *) +type json_type = + Object of (string * json_type) list + | Array of json_type list + | String of string + | Int of int + | Float of float + | Bool of bool + | Null + +(** [t] is an alias for [json_type]. *) +type t = json_type + +(** Errors that are produced by the json-wheel library are represented + using the [Json_error] exception. + + Other exceptions may be raised when calling functions from the library. + Either they come from + the failure of external functions or like [Not_found] they + are not errors per se, and are specifically documented. +*) +exception Json_error of string + +(** This submodule provides some simple functions for checking + and reading the structure of JSON data. + + Use [open Json_type.Browse] when you want to convert JSON data + into another OCaml type. +*) +module Browse : + sig +(** [make_table] creates a hash table from the contents of a JSON [Object]. + For example, if [x] is a JSON [Object], then the corresponding table + can be created by [let tbl = make_table (objekt x)]. + + Hash tables are more efficient than lists + if several fields must be extracted + and converted into something like an OCaml record. + + The key/value pairs are added from left to right. + Therefore if there are several bindings for the same key, the latest + to appear in the list will be the first in the list + returned by [Hashtbl.find_all]. *) + val make_table : (string * t) list -> (string, t) Hashtbl.t + +(** [field tbl key] looks for a unique field [key] in hash table [tbl]. + It raises a [Json_error] if [key] is not found in the table + or if it is present multiple times. *) + val field : (string, t) Hashtbl.t -> string -> t + +(** [fieldx tbl key] works like [field tbl key], but returns [Null] if + [key] is not found in the table. This function is convenient when + assuming that a field which is set to [Null] is the same + as if it were not defined. + + For instance, [optional int (fieldx tbl "year")] looks in + table [tbl] for a field ["year"]. If this field is set to [Null] + or if it is undefined, then [None] is returned, otherwise + an [Int] is expected and returned, for example as [Some 2006]. + If the value is of another JSON type than [Int] or [Null], it causes an + error. *) + val fieldx : (string, t) Hashtbl.t -> string -> t + +(** [optfield tbl key] queries hash table [tbl] for zero or one field [key]. + The result is returned as [None] or [Some result]. If there are several + fields with the same [key], then a [Json_error] is produced. + + [Null] is returned as [Some Null], not + as [None]. For other behaviors see {!Json_type.Browse.fieldx} + and {!Json_type.Browse.optfieldx}. *) + val optfield : (string, t) Hashtbl.t -> string -> t option + +(** [optfieldx] is the same as [optfield] except that it + will never return [Some Null] + but [None] instead. *) + val optfieldx : (string, t) Hashtbl.t -> string -> t option + + +(** [describe x] returns a short description of the given JSON data. + Its purpose is to help build error messages. *) + val describe : t -> string + +(** [type_mismatch expected x] raises the [Json_error msg] exception, + where [msg] is a message that describes the error as a type mismatch + between the element [x] and what is [expected]. *) + val type_mismatch : string -> t -> 'a + +(** tells whether the given JSON element is null *) + val is_null : t -> bool + +(** tells whether the given JSON element is not null *) + val is_defined : t -> bool + +(** raises a [Json_error] exception if the given JSON value is not [Null]. *) + val null : t -> unit + +(** reads a JSON element as a string or raises a [Json_error] exception. *) + val string : t -> string + +(** reads a JSON element as a bool or raises a [Json_error] exception. *) + val bool : t -> bool + +(** reads a JSON element as an int or a float and returns a float + or raises a [Json_error] exception. *) + val number : t -> float + +(** reads a JSON element as an int or raises a [Json_error] exception. *) + val int : t -> int + +(** reads a JSON element as a float or raises a [Json_error] exception. *) + val float : t -> float + +(** reads a JSON element as a JSON [Array] and returns an OCaml list, + or raises a [Json_error] exception. *) + val array : t -> t list + +(** reads a JSON element as a JSON [Object] and returns an OCaml list, + or raises a [Json_error] exception. + + Note the unusual spelling. [object] being + a keyword in OCaml, we use [objekt]. [Object] with a capital is still + spelled [Object]. *) + val objekt : t -> (string * t) list + +(** [list f x] maps a JSON [Array x] to an OCaml list, + converting each element + of list [x] using [f]. A [Json_error] exception is raised if + the given element is not a JSON [Array]. + + For example, converting a JSON array that must contain only ints + is performed using [list int x]. Similarly, a list of lists of ints + can be obtained using [list (list int) x]. *) + val list : (t -> 'a) -> t -> 'a list + +(** [option x] returns [None] is [x] is [Null] and [Some x] otherwise. *) + val option : t -> t option + +(** [optional f x] maps x using the given function [f] and returns + [Some result], unless [x] is [Null] in which case it returns [None]. + + For example, [optional int x] may return something like + [Some 123] or [None] or raise a [Json_error] exception in case + [x] is neither [Null] nor an [Int]. + + See also {!Json_type.Browse.fieldx}. *) + val optional : (t -> 'a) -> t -> 'a option + +(**/**) + val assert_object_or_array : t -> unit + end + + +(** This submodule provides some simple functions for building + JSON data from other OCaml types. + + Use [open Json_type.Build] when you want to convert JSON data + into another OCaml type. +*) +module Build : + sig + val null : t + (** The [Null] value *) + + val bool : bool -> t + (** builds a JSON [Bool] *) + + val int : int -> t + (** builds a JSON [Int] *) + + val float : float -> t + (** builds a JSON [Float] *) + + val string : string -> t + (** builds a JSON [String] *) + + val objekt : (string * t) list -> t + (** builds a JSON [Object]. + + See {!Json_type.Browse.objekt} for an explanation about the unusual + spelling. *) + + val array : t list -> t + (** builds a JSON [Array]. *) + + val list : ('a -> t) -> 'a list -> t + (** [list f l] maps OCaml list [l] to a JSON list using + function [f] to convert the elements into JSON values. + + For example, [list int [1; 2; 3]] is a shortcut for + [Array [ Int 1; Int 2; Int 3 ]]. *) + + val option : t option -> t + (** [option x] returns [Null] is [x] is [None], or [y] if + [x] is [Some y]. *) + + val optional : ('a -> t) -> 'a option -> t + (** [optional f x] returns [Null] if [x] is [None], or [f x] + otherwise. + + For example, [list (optional int) [Some 1; Some 2; None]] returns + [Array [ Int 1; Int 2; Null ]]. *) + end + +(**/**) + +(* pad: *) +val json_of_list: ('a -> t) -> 'a list -> t + + +val string_of_loc : (Lexing.position * Lexing.position) -> string +val json_error : string -> 'a diff --git a/external/jsonwheel/license.txt b/external/jsonwheel/license.txt new file mode 100644 index 0000000..0227a43 --- /dev/null +++ b/external/jsonwheel/license.txt @@ -0,0 +1,22 @@ +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 name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(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/external/jsonwheel/modif-orig.txt b/external/jsonwheel/modif-orig.txt new file mode 100644 index 0000000..4912d48 --- /dev/null +++ b/external/jsonwheel/modif-orig.txt @@ -0,0 +1,8 @@ +Modified Makefile to not require ocamlfind or netstring +and created a slice of json_io.ml in json_out.ml. + +Json-wheel is better structured than sexplib. Martin correctly +realized that people may want to use Json as-is, without the automatic +converting camlp4 stuff. So he splitted in json-wheel and json-static. +They should have done that for sexplib too. Nevertheless he requires +netconversion stuff :( diff --git a/external/jsonwheel/netconversion2.ml b/external/jsonwheel/netconversion2.ml new file mode 100644 index 0000000..cb9585c --- /dev/null +++ b/external/jsonwheel/netconversion2.ml @@ -0,0 +1,8 @@ + +let once = ref false +let ustring_of_uchar x y = + if not !once then begin + prerr_string "(lib-json)ustring_of_uchar: Todo\n"; flush stderr; + once := true + end; + "PBUSTRINGOFCHAR" diff --git a/external/jsonwheel/readme.txt b/external/jsonwheel/readme.txt new file mode 100644 index 0000000..7935c16 --- /dev/null +++ b/external/jsonwheel/readme.txt @@ -0,0 +1,70 @@ +This is an OCaml library which reads and writes data in the JSON format +(JavaScript Object Notation). +This format can be used as a light-weight replacement for XML. +Visit http://www.json.org for more information about JSON. + +The documentation for this library is located at + http://martin.jambon.free.fr/json-wheel/ + + +Installation +============ + +Requirements: +- OCaml +- GNU make +- the findlib library manager (ocamlfind command) +- the netstring library + +From the source directory, do: + + make + make install + +If you want to remove the package do: + + make uninstall + + +Standard compliance +=================== + +The JSON parser, in the default mode, conforms to the specifications +of RFC 4627, with only some limitations due to the implementation +of the corresponding OCaml types: + +* ints that are too large to be represented with the OCaml int type + cause an error. The limit depends whether it is a 32-bit or 64-bit + platform (see min_int and max_int). + +* floats may be represented with reduced precision as they must fit + into the 8 bytes of the "double" format. + +* The size of OCaml strings is limited to about 16MB on 32-bit + platforms, and much more on 64-bit platforms (see Sys.max_string_length). + + +RFC 4627: http://www.ietf.org/rfc/rfc4627.txt?number=4627 + + +The UTF-8 encoding is supported, however no attempt is made at +checking whether strings are actually valid UTF-8 or not. Therefore, other +ASCII-compatible encodings such as the ISO 8859 series are supported +as well. + + +Tests +===== + +Json.org provides a test suite. You can download the file (test.zip), +unzip it in the parent directory, and run "make test". +Look for ERROR messages, which indicate that a file that should fail +actually passes or that a file that should pass fails the test. + +../test/fail18.json doesn't pass: this is only because an int which is +too large for the OCaml int type on a 32-bit platform. + +../test/fail18.json passes: it is marked as "should fail" because is +has a high number of nesting. Although the standard allows such +restrictions, there are not mandatory at all. Our parser does not have +such a restriction. diff --git a/find_source.ml b/find_source.ml new file mode 100644 index 0000000..47e4359 --- /dev/null +++ b/find_source.ml @@ -0,0 +1,140 @@ +open Common + + +let finder lang = + match lang with + | "c++" -> + Lib_parsing_cpp.find_source_files_of_dir_or_files + | "c" -> + Lib_parsing_c.find_source_files_of_dir_or_files + | "dot" -> (fun _ -> []) + | _ -> failwith ("Find_source: unsupported language: " ^ lang) + +let skip_file dir = + Filename.concat dir "skip_list.txt" + + +let files_of_dir_or_files ~lang xs = + let finder = finder lang in + let xs = List.map Common.fullpath xs in + finder xs |> Skip_code.filter_files_if_skip_list + + +(* todo: factorize with filter_files_if_skip_list? *) +let files_of_root ~lang root = + let finder = finder lang in + let files = finder [root] in + + let skip_list = + if Sys.file_exists (skip_file root) + then begin + pr2 (spf "Using skip file: %s" (skip_file root)); + Skip_code.load (skip_file root); + end + else [] + in + let files = Skip_code.filter_files skip_list root files in + files + +(* + let root = Common.realpath dir in + let all_files = Lib_parsing_clang.find_source2_files_of_dir_or_files [root] in + + (* step0: filter noisy modules/files *) + let files = Skip_code.filter_files skip_list root all_files in + (* step0: reorder files *) + let files = Skip_code.reorder_files_skip_errors_last skip_list root files in + + let root = Common.realpath dir_or_file in + let all_files = + Lib_parsing_bytecode.find_source_files_of_dir_or_files [root] in + + (* step0: filter noisy modules/files *) + let files = + Skip_code.filter_files skip_list root all_files in + + let root = Common.realpath dir in + let all_files = Lib_parsing_c.find_source_files_of_dir_or_files [root] in + + (* step0: filter noisy modules/files *) + let files = Skip_code.filter_files skip_list root all_files in + + + let root = Common.realpath dir_or_file in + let all_files = Lib_parsing_java.find_source_files_of_dir_or_files [root] in + + (* step0: filter noisy modules/files *) + let files = Skip_code.filter_files skip_list root all_files in + + let root = Common.realpath dir in + let all_files = Lib_parsing_ml.find_source_files_of_dir_or_files [root] in + + (* step0: filter noisy modules/files *) + let files = Skip_code.filter_files skip_list root all_files in + + + let root = Common.realpath dir in + let all_files = Lib_parsing_cpp.find_source_files_of_dir_or_files [root] in + + (* step0: filter noisy modules/files *) + let files = Skip_code.filter_files skip_list root all_files in + + let root, files = + Common.profile_code "Graph_php.step0" (fun () -> + match dir_or_files with + | Left dir -> + let root = Common.realpath dir in + let files = + Lib_parsing_php.find_php_files_of_dir_or_files [root] + +> Skip_code.filter_files skip_list root + +> Skip_code.reorder_files_skip_errors_last skip_list root + in + root, files + (* useful when build codegraph from test code *) + | Right files -> + "/", files + ) + in + + + + + let root, files = + match dir_or_files with + | Left dir -> + let root = Common.realpath dir in + let all_files = Lib_parsing_php.find_php_files_of_dir_or_files [root] in + + (* step0: filter noisy modules/files *) + let files = + Skip_code.filter_files skip_list root all_files in + (* step0: reorder files *) + let files = + Skip_code.reorder_files_skip_errors_last skip_list root files in + root, files + (* useful when build from test code *) + | Right files -> + "/", files + in + + let skip_file = !skip_list ||| skip_file_of_dir root in + let skip_list = + if Sys.file_exists skip_file + then begin + pr2 (spf "Using skip file: %s" skip_file); + Skip_code.load skip_file + end + else [] + in + let finder = Find_source.finder lang in + + let skip_file = "skip_list.txt" in + let skip_list = + if Sys.file_exists skip_file + then begin + pr2 (spf "Using skip file: %s" skip_file); + Skip_code.load skip_file + end + else [] + in +*) diff --git a/find_source.mli b/find_source.mli new file mode 100644 index 0000000..8737aee --- /dev/null +++ b/find_source.mli @@ -0,0 +1,13 @@ + +(* will manage optional skip list at root *) +val files_of_root: + lang:string -> + Common.dirname -> Common.filename list + +(* will manage optional skip list at root of vcs *) +val files_of_dir_or_files: + lang:string -> + Common.path list -> Common.filename list + + +val finder: string -> (Common.path list -> Common.filename list) diff --git a/globals/.depend b/globals/.depend new file mode 100644 index 0000000..93ec685 --- /dev/null +++ b/globals/.depend @@ -0,0 +1,2 @@ +config_pfff.cmo : +config_pfff.cmx : diff --git a/globals/META b/globals/META new file mode 100644 index 0000000..e88aa4f --- /dev/null +++ b/globals/META @@ -0,0 +1,4 @@ +description = "required pfff modules when using -linkall, from pfff" +requires = "unix num" +archive(byte) = "lib.cma" +archive(native) = "lib.cmxa" diff --git a/globals/Makefile b/globals/Makefile new file mode 100644 index 0000000..f72ae48 --- /dev/null +++ b/globals/Makefile @@ -0,0 +1,49 @@ +TOP=.. +-include $(TOP)/Makefile.config + +############################################################################## +# Variables +############################################################################## +TARGET=lib + +SRC= config_pfff.ml + +LIBS= +INCLUDEDIRS=../commons + +############################################################################## +# Generic +############################################################################## +-include $(TOP)/Makefile.common + +############################################################################## +# Top rules +############################################################################## +all:: $(TARGET).cma + +all.opt: $(TARGET).cmxa + +$(TARGET).cma: $(OBJS) $(LIBS) + $(OCAMLC) -a -o $(TARGET).cma $(OBJS) + +$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa) + $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS) + + +config_pfff.ml: + @echo "config_pfff.ml is missing. Have you run ./configure?" + @exit 1 + +distclean:: + rm -f config_pfff.ml + +############################################################################## +# install +############################################################################## +LIBNAME=pfff-config +EXPORTSRC=\ + +install-findlib: all all.opt + ocamlfind install $(LIBNAME) META \ + lib.cma lib.cmxa lib.a \ + $(EXPORTSRC) $(EXPORTSRC:%.mli=%.cmi) \ diff --git a/globals/config_pfff.ml b/globals/config_pfff.ml new file mode 100644 index 0000000..579b7e2 --- /dev/null +++ b/globals/config_pfff.ml @@ -0,0 +1,11 @@ +let version = "0.29" + +let path = + try (Sys.getenv "PFFF_HOME") + with Not_found->"/usr/local/share/pfff" + +let std_xxx = ref (Filename.concat path "xxx.yyy") + +let logger = + try Some (Sys.getenv "PFFF_LOGGER") + with Not_found-> None diff --git a/globals/config_pfff.ml.in b/globals/config_pfff.ml.in new file mode 100644 index 0000000..0239be8 --- /dev/null +++ b/globals/config_pfff.ml.in @@ -0,0 +1,11 @@ +let version = "0.29" + +let path = + try (Sys.getenv "PFFF_HOME") + with Not_found1->"/usr/local/share/pfff" + +let std_xxx = ref (Filename.concat path "xxx.yyy") + +let logger = + try Some (Sys.getenv "PFFF_LOGGER") + with Not_found2-> None diff --git a/h_files-format/.depend b/h_files-format/.depend new file mode 100644 index 0000000..3be9c1d --- /dev/null +++ b/h_files-format/.depend @@ -0,0 +1,13 @@ +outline.cmo : ../commons/common2.cmi ../commons/common.cmi outline.cmi +outline.cmx : ../commons/common2.cmx ../commons/common.cmx outline.cmi +outline.cmi : ../commons/common2.cmi ../commons/common.cmi +simple_format.cmo : ../commons/common2.cmi ../commons/common.cmi \ + simple_format.cmi +simple_format.cmx : ../commons/common2.cmx ../commons/common.cmx \ + simple_format.cmi +simple_format.cmi : ../commons/common2.cmi +source_tree.cmo : simple_format.cmi ../commons/common2.cmi \ + ../commons/common.cmi source_tree.cmi +source_tree.cmx : simple_format.cmx ../commons/common2.cmx \ + ../commons/common.cmx source_tree.cmi +source_tree.cmi : ../commons/common.cmi diff --git a/h_files-format/META b/h_files-format/META new file mode 100644 index 0000000..3cc6755 --- /dev/null +++ b/h_files-format/META @@ -0,0 +1,4 @@ +description = "Helper functions for dealing with file format, from pfff" +requires = "unix num" +archive(byte) = "lib.cma" +archive(native) = "lib.cmxa" diff --git a/h_files-format/Makefile b/h_files-format/Makefile new file mode 100644 index 0000000..802db3e --- /dev/null +++ b/h_files-format/Makefile @@ -0,0 +1,42 @@ +TOP=.. +############################################################################## +# Variables +############################################################################## +TARGET=lib + +SRC= outline.ml simple_format.ml source_tree.ml + +LIBS=$(TOP)/commons/lib.cma +INCLUDEDIRS= $(TOP)/commons + +############################################################################## +# Generic variables +############################################################################## + +-include $(TOP)/Makefile.common + +############################################################################## +# Top rules +############################################################################## +all:: $(TARGET).cma +all.opt:: $(TARGET).cmxa +opt:: all.opt + + +$(TARGET).cma: $(OBJS) $(LIBS) + $(OCAMLC) -a -o $(TARGET).cma $(OBJS) + +$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa) + $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS) + +############################################################################## +# install +############################################################################## +LIBNAME=pfff-h_files-format +EXPORTSRC=\ + outline.mli + +install-findlib: all all.opt + ocamlfind install $(LIBNAME) META \ + lib.cma lib.cmxa lib.a \ + $(EXPORTSRC) $(EXPORTSRC:%.mli=%.cmi) \ diff --git a/h_files-format/authors.txt b/h_files-format/authors.txt new file mode 100644 index 0000000..8b23926 --- /dev/null +++ b/h_files-format/authors.txt @@ -0,0 +1,2 @@ +Yoann Padioleau + diff --git a/h_files-format/copyright.txt b/h_files-format/copyright.txt new file mode 100644 index 0000000..2f662c1 --- /dev/null +++ b/h_files-format/copyright.txt @@ -0,0 +1,17 @@ +Copyright (C) 2008 Yoann Padioleau + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public License (LGPL) + version 2.1 as published by the Free Software Foundation, with the + special exception on linking described in file license.txt. + + This library 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 file + license.txt for more details. + + +The contents of some files in this directory was derived from external +sources with compatible licenses. The original copyright and license +notice was preserved in the affected files. + diff --git a/h_files-format/credits.txt b/h_files-format/credits.txt new file mode 100644 index 0000000..e69de29 diff --git a/h_files-format/license.txt b/h_files-format/license.txt new file mode 100644 index 0000000..67b72ca --- /dev/null +++ b/h_files-format/license.txt @@ -0,0 +1,520 @@ +The Library is distributed under the terms of the GNU Lesser General +Public License version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute that +executable file under terms of your choice, without any of the additional +requirements listed in clause 6 of the GNU Lesser General Public License. +By "a publicly distributed version of the Library", we mean either the +unmodified Library as distributed by the authors, or a modified version +of the Library that is distributed under the conditions defined in clause +3 of the GNU Lesser General Public License. This exception does not +however invalidate any other reasons why the executable file might be +covered by the GNU Lesser General Public License. + +--------------------------------------------------------------------------- + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/h_files-format/outline.ml b/h_files-format/outline.ml new file mode 100644 index 0000000..3663313 --- /dev/null +++ b/h_files-format/outline.ml @@ -0,0 +1,116 @@ +open Common + +(*****************************************************************************) +(* The data structure *) +(*****************************************************************************) + +type outline_node = { + stars: string; + title: string; + before_first_children: string list; +} +type outline = outline_node Common2.tree2 + +let outline_default_regexp = "^\\(\\*+\\)[ ]*\\(.*\\)" + +let root_stars = "" +let root_title = "__ROOT__" + +(*****************************************************************************) +(* Helpers, accessors *) +(*****************************************************************************) + +let is_root_node node = + String.length node.stars = 0 && + node.title = root_title + + +let extract_outline_line ?(outline_regexp=outline_default_regexp) s = + if s =~ outline_regexp + then matched2 s + else failwith (spf "line does not match regexp: %s vs %s" s outline_regexp) + + +(*****************************************************************************) +(* Loading, saving *) +(*****************************************************************************) + +(* Similar to parenthesizd expression parsing, or ifdef parsing as + * in parsing_hacks, but a little different cos don't have the + * end delimiter in most cases. The end delimiter is in fact + * the start of a new header or the end of the file. + *) +let parse_outline ?(outline_regexp=outline_default_regexp) file = + let xs = Common.cat file in + + (* just differentiate outline lines from regular lines *) + let headers_or_not = + xs +> List.map (fun s -> + if s =~ outline_regexp + then + let (stars, line) = extract_outline_line ~outline_regexp s in + Left (String.length stars, stars, line) + else + Right s + ) + in + let root = (0, root_stars, root_title) in + (* pack the Right with each appropriate Left *) + let headers = + let rec aux (acc_right, outline) xs = + match xs with + | [] -> [(outline, List.rev acc_right)] + | x::xs -> + (match x with + | Right regular -> + aux (regular::acc_right, outline) xs + | Left outline2 -> + (outline, List.rev acc_right)::aux ([], outline2) xs + ) + in + aux ([], root) headers_or_not + in + + (* build the tree *) + let trees = + let rec aux_outline xs = + match xs with + | [] -> [] + | x::xs -> + let ((lvl, stars, title), before_first_children) = x in + + let (children, rest) = xs +> Common2.span (fun x2 -> + let ((lvl2, _, _), _) = x2 in + lvl2 > lvl + ) + in + let node = + { stars = stars; + title = title; + before_first_children = before_first_children; + } + in + let children_trees = aux_outline children in + + (Common2.Tree (node, children_trees))::aux_outline rest + in + aux_outline headers + in + match trees with + | [root] -> root + | _ -> failwith "wierd, multiple roots" + + + +let write_outline outline file = + Common.with_open_outfile file (fun (pr_no_nl, _chan) -> + let pr s = pr_no_nl (s ^ "\n") in + + outline +> Common2.tree2_iter (fun node -> + if not (is_root_node node) + then pr (node.stars ^ node.title); + + node.before_first_children +> List.iter pr; + ); + ) + diff --git a/h_files-format/outline.mli b/h_files-format/outline.mli new file mode 100644 index 0000000..123ae6a --- /dev/null +++ b/h_files-format/outline.mli @@ -0,0 +1,20 @@ + +type outline = outline_node Common2.tree2 + and outline_node = { + stars : string; + title : string; + before_first_children : string list; + } + + + +val outline_default_regexp : string + +(* value for implicit root *) +val root_title : string +val root_stars : string +val is_root_node : outline_node -> bool + + +val parse_outline : ?outline_regexp:string -> Common.filename -> outline +val write_outline : outline -> Common.filename -> unit diff --git a/h_files-format/simple_format.ml b/h_files-format/simple_format.ml new file mode 100644 index 0000000..21e3adb --- /dev/null +++ b/h_files-format/simple_format.ml @@ -0,0 +1,48 @@ +open Common + + +let regexp_comment_line = "#.*" + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let cat_and_filter_comments file = + let xs = Common.cat file in + let xs = xs +> List.map + (Str.global_replace (Str.regexp regexp_comment_line) "" ) in + let xs = xs +> Common.exclude Common2.is_blank_string in + xs + +(*****************************************************************************) +(* csv *) + + +(*****************************************************************************) +(* hierarchy ? header of section like in kernel_files.meta ? *) + +(* + (* split by header of section *) + .. + let xs = xs +> Common.split_list_regexp "^[^ ]" in + + let group = xs +> List.map (fun s -> + assert (s =~ "^[ ]+\\([^ ]+\\) *: *\\(.*\\)"); + let (dir, email) = matched2 s in + let emails = Common.split "[ ,]+" email in + (dir, emails) + ) in + Subsystem ((dir, emails), group) +*) + +(*****************************************************************************) +let title_colon_elems_space_separated file = + + let xs = cat_and_filter_comments file in + + xs +> List.map (fun s -> + assert (s =~ "^\\([^ ]+\\):\\(.*\\)"); + let (title, elems_str) = matched2 s in + let elems = Common.split "[ \t]+" elems_str in + title, elems + ) diff --git a/h_files-format/simple_format.mli b/h_files-format/simple_format.mli new file mode 100644 index 0000000..e3f3a43 --- /dev/null +++ b/h_files-format/simple_format.mli @@ -0,0 +1,8 @@ +open Common2.BasicType + +val regexp_comment_line : string + +val cat_and_filter_comments : filename -> string list + +val title_colon_elems_space_separated : + filename -> (string * string list) list diff --git a/h_files-format/source_tree.ml b/h_files-format/source_tree.ml new file mode 100644 index 0000000..d259fb0 --- /dev/null +++ b/h_files-format/source_tree.ml @@ -0,0 +1,125 @@ +open Common + + +type subsystem = SubSystem of string +type dir = Dir of string + +let string_of_subsystem (SubSystem s) = s +let string_of_dir (Dir s) = s + +type tree_reorganization = (subsystem * dir list) list + +let dir_to_dirfinal (Dir s) = + Str.global_replace (Str.regexp "/") "___" s + +(* +let dirfinal_of_dir s = + Dir (Str.global_replace (Str.regexp "___") "/" s) +*) + + +let all_subsystem reorg = + reorg +> List.map fst +> List.map string_of_subsystem +let all_dirs reorg = + reorg +> List.map snd +> List.concat +> List.map string_of_dir + +let reverse_index reorg = + let res = ref [] in + reorg +> List.iter (fun (SubSystem s1, dirs) -> + dirs +> List.iter (fun (Dir s2) -> + push (Dir s2, SubSystem s1) res; + ); + ); + List.rev !res + + + + +let (load_tree_reorganization : Common.filename -> tree_reorganization) = + fun file -> + let xs = Simple_format.title_colon_elems_space_separated file in + xs +> List.map (fun (title, elems) -> + SubSystem title, elems +> List.map (fun s -> Dir s) + ) + +let debug_source_tree = false + +let change_organization_dirs_to_subsystems reorg basedir = + let cmd s = + if debug_source_tree + then pr2 s + else Common.command2 s + in + reorg +> List.iter (fun (SubSystem sub, dirs) -> + if not debug_source_tree + then Common2.mkdir (spf "%s/%s" basedir sub); + + dirs +> List.iter (fun (Dir dir) -> + let dir' = dir_to_dirfinal (Dir dir) in + cmd (spf "mv %s/%s %s/%s/%s" basedir dir basedir sub dir') + ); + ); + () + +let change_organization_subsystems_to_dirs reorg basedir = + let cmd s = + if debug_source_tree + then pr2 s + else Common.command2 s + in + reorg +> List.iter (fun (SubSystem sub, dirs) -> + dirs +> List.iter (fun (Dir dir) -> + let dir' = dir_to_dirfinal (Dir dir) in + cmd (spf "mv %s/%s/%s %s/%s" basedir sub dir' basedir dir) + ); + if not debug_source_tree + then Unix.rmdir (spf "%s/%s" basedir sub); + ); + () + + + +let (change_organization: + tree_reorganization -> Common.filename (* dir *) -> unit) = + fun reorg dir -> + pr2_gen reorg; + pr2_gen dir; + + + let subsystem_bools = + all_subsystem reorg + +> List.map (fun s -> (Sys.file_exists (Filename.concat dir s))) + in + let dirs_bools = + all_dirs reorg + +> List.map (fun s -> (Sys.file_exists (Filename.concat dir s))) + in + match () with + | _ when Common2.and_list subsystem_bools -> + assert (not (Common2.or_list dirs_bools)); + change_organization_subsystems_to_dirs reorg dir; + | _ when Common2.and_list dirs_bools -> + assert (not (Common2.or_list subsystem_bools)); + change_organization_dirs_to_subsystems reorg dir; + | _ -> failwith "have a mix of subsystem and dirs, wierd" + + + + +let subsystem_of_dir2 (Dir dir) reorg = + let index = reverse_index reorg in + let dirsplit = Common.split "/" dir in + let index = + index +> List.map (fun (Dir d, sub) -> Common.split "/" d, sub) + in + try + index +> List.find (fun (dirsplit2, _sub) -> + let len = List.length dirsplit2 in + Common2.take_safe len dirsplit = dirsplit2 + ) +> snd + with Not_found -> + pr2 (spf "Cant find %s in reorganization information" dir); + raise Not_found + +let subsystem_of_dir a b = + Common.profile_code "subsystem_of_dir" (fun () -> subsystem_of_dir2 a b) diff --git a/h_files-format/source_tree.mli b/h_files-format/source_tree.mli new file mode 100644 index 0000000..344cf0b --- /dev/null +++ b/h_files-format/source_tree.mli @@ -0,0 +1,16 @@ + +type subsystem = SubSystem of string +type dir = Dir of string + +type tree_reorganization = (subsystem * dir list) list + + + +val load_tree_reorganization : + Common.filename -> tree_reorganization + +val change_organization: + tree_reorganization -> Common.filename (* dir *) -> unit + +val subsystem_of_dir : + dir -> tree_reorganization -> subsystem diff --git a/h_program-lang/.depend b/h_program-lang/.depend new file mode 100644 index 0000000..5641d32 --- /dev/null +++ b/h_program-lang/.depend @@ -0,0 +1,132 @@ +archi_code.cmo : ../commons/common2.cmi ../commons/common.cmi archi_code.cmi +archi_code.cmx : ../commons/common2.cmx ../commons/common.cmx archi_code.cmi +archi_code.cmi : ../commons/common.cmi +archi_code_lexer.cmo : archi_code.cmi +archi_code_lexer.cmx : archi_code.cmx +archi_code_parse.cmo : ../commons/common2.cmi ../commons/common.cmi \ + archi_code_lexer.cmo archi_code.cmi archi_code_parse.cmi +archi_code_parse.cmx : ../commons/common2.cmx ../commons/common.cmx \ + archi_code_lexer.cmx archi_code.cmx archi_code_parse.cmi +archi_code_parse.cmi : ../commons/common.cmi archi_code.cmi +ast_fuzzy.cmo : parse_info.cmi ../commons/ocaml.cmi ../commons/common.cmi \ + ast_fuzzy.cmi +ast_fuzzy.cmx : parse_info.cmx ../commons/ocaml.cmx ../commons/common.cmx \ + ast_fuzzy.cmi +ast_fuzzy.cmi : parse_info.cmi ../commons/ocaml.cmi ../commons/common.cmi +big_grep.cmo : database_code.cmi ../commons/common2.cmi \ + ../commons/common.cmi big_grep.cmi +big_grep.cmx : database_code.cmx ../commons/common2.cmx \ + ../commons/common.cmx big_grep.cmi +big_grep.cmi : database_code.cmi +comment_code.cmo : parse_info.cmi ../commons/common2.cmi \ + ../commons/common.cmi comment_code.cmi +comment_code.cmx : parse_info.cmx ../commons/common2.cmx \ + ../commons/common.cmx comment_code.cmi +comment_code.cmi : parse_info.cmi +coverage_code.cmo : ../external/jsonwheel/json_type.cmi \ + ../external/jsonwheel/json_out.cmo ../external/jsonwheel/json_in.cmo \ + ../commons/common.cmi coverage_code.cmi +coverage_code.cmx : ../external/jsonwheel/json_type.cmx \ + ../external/jsonwheel/json_out.cmx ../external/jsonwheel/json_in.cmx \ + ../commons/common.cmx coverage_code.cmi +coverage_code.cmi : ../external/jsonwheel/json_type.cmi \ + ../commons/common.cmi +database_code.cmo : ../external/jsonwheel/json_type.cmi \ + ../external/jsonwheel/json_io.cmi ../external/jsonwheel/json_in.cmo \ + highlight_code.cmi ../commons/file_type.cmi entity_code.cmi \ + ../commons/common2.cmi ../commons/common.cmi database_code.cmi +database_code.cmx : ../external/jsonwheel/json_type.cmx \ + ../external/jsonwheel/json_io.cmx ../external/jsonwheel/json_in.cmx \ + highlight_code.cmx ../commons/file_type.cmx entity_code.cmx \ + ../commons/common2.cmx ../commons/common.cmx database_code.cmi +database_code.cmi : highlight_code.cmi entity_code.cmi \ + ../commons/common2.cmi ../commons/common.cmi +datalog_code.cmo : ../commons/common2.cmi ../commons/common.cmi \ + datalog_code.cmi +datalog_code.cmx : ../commons/common2.cmx ../commons/common.cmx \ + datalog_code.cmi +datalog_code.cmi : ../commons/common.cmi +entity_code.cmo : ../commons/common.cmi entity_code.cmi +entity_code.cmx : ../commons/common.cmx entity_code.cmi +entity_code.cmi : +errors_code.cmo : scope_code.cmi parse_info.cmi entity_code.cmi \ + ../commons/common2.cmi ../commons/common.cmi errors_code.cmi +errors_code.cmx : scope_code.cmx parse_info.cmx entity_code.cmx \ + ../commons/common2.cmx ../commons/common.cmx errors_code.cmi +errors_code.cmi : scope_code.cmi parse_info.cmi entity_code.cmi \ + ../commons/common.cmi +highlight_code.cmo : entity_code.cmi ../commons/common.cmi \ + highlight_code.cmi +highlight_code.cmx : entity_code.cmx ../commons/common.cmx \ + highlight_code.cmi +highlight_code.cmi : entity_code.cmi +info_code.cmo : ../h_files-format/outline.cmi info_code.cmi +info_code.cmx : ../h_files-format/outline.cmx info_code.cmi +info_code.cmi : ../h_files-format/outline.cmi ../commons/common.cmi +layer_code.cmo : parse_info.cmi ../commons/ocaml.cmi \ + ../external/jsonwheel/json_type.cmi ../external/jsonwheel/json_out.cmo \ + ../external/jsonwheel/json_in.cmo ../commons/file_type.cmi \ + ../commons/common2.cmi ../commons/common.cmi layer_code.cmi +layer_code.cmx : parse_info.cmx ../commons/ocaml.cmx \ + ../external/jsonwheel/json_type.cmx ../external/jsonwheel/json_out.cmx \ + ../external/jsonwheel/json_in.cmx ../commons/file_type.cmx \ + ../commons/common2.cmx ../commons/common.cmx layer_code.cmi +layer_code.cmi : parse_info.cmi ../external/jsonwheel/json_type.cmi \ + ../commons/common.cmi +layer_coverage.cmo : layer_code.cmi coverage_code.cmi ../commons/common2.cmi \ + ../commons/common.cmi layer_coverage.cmi +layer_coverage.cmx : layer_code.cmx coverage_code.cmx ../commons/common2.cmx \ + ../commons/common.cmx layer_coverage.cmi +layer_coverage.cmi : layer_code.cmi coverage_code.cmi ../commons/common.cmi +layer_parse_errors.cmo : parse_info.cmi layer_code.cmi \ + ../commons/common2.cmi ../commons/common.cmi layer_parse_errors.cmi +layer_parse_errors.cmx : parse_info.cmx layer_code.cmx \ + ../commons/common2.cmx ../commons/common.cmx layer_parse_errors.cmi +layer_parse_errors.cmi : parse_info.cmi layer_code.cmi ../commons/common.cmi +meta_ast_generic.cmo : meta_ast_generic.cmi +meta_ast_generic.cmx : meta_ast_generic.cmi +meta_ast_generic.cmi : +overlay_code.cmo : layer_code.cmi database_code.cmi ../commons/common2.cmi \ + ../commons/common.cmi overlay_code.cmi +overlay_code.cmx : layer_code.cmx database_code.cmx ../commons/common2.cmx \ + ../commons/common.cmx overlay_code.cmi +overlay_code.cmi : layer_code.cmi database_code.cmi ../commons/common.cmi +parse_info.cmo : ../commons/ocaml.cmi ../commons/common2.cmi \ + ../commons/common.cmi parse_info.cmi +parse_info.cmx : ../commons/ocaml.cmx ../commons/common2.cmx \ + ../commons/common.cmx parse_info.cmi +parse_info.cmi : ../commons/ocaml.cmi ../commons/common.cmi +pleac.cmo : ../commons/common2.cmi ../commons/common.cmi pleac.cmi +pleac.cmx : ../commons/common2.cmx ../commons/common.cmx pleac.cmi +pleac.cmi : ../commons/common.cmi +pretty_print_code.cmo : ../commons/common2.cmi +pretty_print_code.cmx : ../commons/common2.cmx +prolog_code.cmo : entity_code.cmi ../commons/common.cmi prolog_code.cmi +prolog_code.cmx : entity_code.cmx ../commons/common.cmx prolog_code.cmi +prolog_code.cmi : entity_code.cmi ../commons/common.cmi +refactoring_code.cmo : ../commons/common.cmi refactoring_code.cmi +refactoring_code.cmx : ../commons/common.cmx refactoring_code.cmi +refactoring_code.cmi : ../commons/common.cmi +scope_code.cmo : ../commons/ocaml.cmi scope_code.cmi +scope_code.cmx : ../commons/ocaml.cmx scope_code.cmi +scope_code.cmi : ../commons/ocaml.cmi +skip_code.cmo : ../commons/common2.cmi ../commons/common.cmi skip_code.cmi +skip_code.cmx : ../commons/common2.cmx ../commons/common.cmx skip_code.cmi +skip_code.cmi : ../commons/common.cmi +tags_file.cmo : parse_info.cmi entity_code.cmi ../commons/common.cmi \ + tags_file.cmi +tags_file.cmx : parse_info.cmx entity_code.cmx ../commons/common.cmx \ + tags_file.cmi +tags_file.cmi : parse_info.cmi entity_code.cmi ../commons/common.cmi +test_program_lang.cmo : refactoring_code.cmi layer_code.cmi \ + ../external/jsonwheel/json_out.cmo entity_code.cmi database_code.cmi \ + ../commons/common.cmi big_grep.cmi test_program_lang.cmi +test_program_lang.cmx : refactoring_code.cmx layer_code.cmx \ + ../external/jsonwheel/json_out.cmx entity_code.cmx database_code.cmx \ + ../commons/common.cmx big_grep.cmx test_program_lang.cmi +test_program_lang.cmi : ../commons/common.cmi +unit_program_lang.cmo : ../commons/oUnit.cmi entity_code.cmi \ + unit_program_lang.cmi +unit_program_lang.cmx : ../commons/oUnit.cmx entity_code.cmx \ + unit_program_lang.cmi +unit_program_lang.cmi : ../commons/oUnit.cmi diff --git a/h_program-lang/META b/h_program-lang/META new file mode 100644 index 0000000..b67d638 --- /dev/null +++ b/h_program-lang/META @@ -0,0 +1,4 @@ +description = "Helper functions for parsing, analyzing, from pfff" +requires = "unix num" +archive(byte) = "lib.cma" +archive(native) = "lib.cmxa" diff --git a/h_program-lang/Makefile b/h_program-lang/Makefile new file mode 100644 index 0000000..593f42e --- /dev/null +++ b/h_program-lang/Makefile @@ -0,0 +1,71 @@ +TOP=.. +############################################################################## +# Variables +############################################################################## +TARGET=lib + +SRC= parse_info.ml \ + ast_fuzzy.ml meta_ast_generic.ml \ + skip_code.ml \ + scope_code.ml \ + pretty_print_code.ml + +# See also graph_code/graph_code.ml! closely related to h_program-lang/ + +SYSLIBS= str.cma unix.cma +LIBS=../commons/lib.cma +INCLUDEDIRS= $(TOP)/commons \ + $(TOP)/external/jsonwheel \ + $(TOP)/h_files-format + +# other sources: +# prolog_code.pl, facts.pl, for the prolog-based code query engine + +# dead: visitor_code, statistics_code, programming-language, ast_generic +############################################################################## +# Generic variables +############################################################################## + +-include $(TOP)/Makefile.common + +############################################################################## +# Top rules +############################################################################## +all:: $(TARGET).cma +all.opt:: $(TARGET).cmxa + +$(TARGET).cma: $(OBJS) + $(OCAMLC) -a -o $(TARGET).cma $(OBJS) + +$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa) + $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS) + +$(TARGET).top: $(OBJS) $(LIBS) + $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS) + +clean:: + rm -f $(TARGET).top + + +archi_code_lexer.ml: archi_code_lexer.mll + $(OCAMLLEX) $< +clean:: + rm -f archi_code_lexer.ml +beforedepend:: archi_code_lexer.ml + +############################################################################## +# install +############################################################################## +LIBNAME=pfff-h_program-lang +EXPORTSRC=\ + ast_fuzzy.mli \ + meta_ast_generic.mli \ + parse_info.mli \ + scope_code.mli \ + skip_code.mli + +install-findlib: all all.opt + ocamlfind install $(LIBNAME) META \ + lib.cma lib.cmxa lib.a \ + $(EXPORTSRC) $(EXPORTSRC:%.mli=%.cmi) \ + pretty_print_code.cmi diff --git a/h_program-lang/archi_code.ml b/h_program-lang/archi_code.ml new file mode 100644 index 0000000..345cf98 --- /dev/null +++ b/h_program-lang/archi_code.ml @@ -0,0 +1,212 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Categorizing a source file according to recurring architecture "aspects" + * (really a directory structure) of a project. We often have some tests/, + * some commons/ library, some include/, etc. + * + * A file may belong to multiple categories at once. + * + * Right now the "aspects" are slightly modeled according to my + * own code and facebook flib code. + * + * This is used by codemap to colorize files. This is also used + * mainly for its AutoGenerated category in pfff -test_loc to + * not count auto generated code in the LOC of a project. This + * can also be used in the deadcode detector to not count auto + * generated files (e.g. visitor_xxx.ml) as real users of an entity. + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* coupling: if add category, dont forget to extend the source_archi_list + * below + *) +type source_archi = + | Main + | Init + | Interface + + (* I put Test and Logging together because if some dirs do not have some + * unit tests, but have some code to logs his action, then it's quite + * similar. Such code should be more robust and it's good to see it + * visually. + *) + | Test + | Logging + + | Core + | Utils (* utils base common *) + + | Constants + | GetSet (* mutators, accessors *) + + | Configuration (* settings *) + | Building (* makefiles *) + | Data (* big files *) + | Doc + + | Ui (* ui render display *) + | Storage (* storage db *) + | Parsing (* scanner, parser *) + | Security + | I18n + (* todo? + * Memory (e.g. malloc, buffer), Fonts (font, charset) + * IO (e.g. keyboard, mouse) + * Strings (e.g. regex + *) + + | Architecture (* e.g. x86 *) + | OS (* e.g. win32, macos, unix *) + | Network (* e.g. protocols ssh, ftp *) + + | Ffi + | ThirdParty (* external *) + | Legacy (* legacy, deprecated *) + + | AutoGenerated + | BoilerPlate + + (* a project often contains itself some infrastructure to run tests or + * benchmarks. + *) + | Unittester + | Profiler + + | MiniLite + | Intern + + | Script + + | Regular + (* with tarzan *) + + +let source_archi_list = [ + Main; Init; + Interface; + Test; Logging; + Core; Utils; + Configuration; Building; + Doc; Data; + Constants; + GetSet; + Ui; Storage; Parsing; Security; I18n; + Architecture; OS; Network; + Script; + ThirdParty; Legacy; Ffi; + AutoGenerated; BoilerPlate; + Unittester; Profiler; + MiniLite; + Intern; + Regular; +] + +type source_kind = + | Header + | Source + +(*****************************************************************************) +(* String of *) +(*****************************************************************************) + +(* ocamltarzan generated *) +let s_of_source_archi = + function + | Init -> "Init" + | Main -> "Main" + | Interface -> "Interface" + | AutoGenerated -> "AutoGenerated" + | BoilerPlate -> "BoilerPlate" + | Test -> "Test" + | Logging -> "Logging" + | Core -> "Core" + | Utils -> "Utils" + | Constants -> "Constants" + | Script -> "Script" + | Ffi -> "Ffi" + | Configuration -> "Configuration" + | Building -> "Building" + | GetSet -> "GetSet" + | Ui -> "Ui" + | Storage -> "Storage" + | Parsing -> "Parsing" + | ThirdParty -> "ThirdParty" + | Legacy -> "Legacy" + | Unittester -> "Unittester" + | Profiler -> "Profiler" + | Intern -> "Intern" + | Regular -> "Regular" + | Doc -> "Doc" + | Data -> "Data" + | MiniLite -> "MiniLite" + | Security -> "Security" + | I18n -> "I18n" + | Architecture -> "Architecture" + | OS -> "OS" + | Network -> "Network" + +(*****************************************************************************) +(* Misc *) +(*****************************************************************************) + +(* TODO move this elsewhere *) +let find_duplicate_dirname dir = + + let h = Hashtbl.create 101 in + let dups = Common2.hash_with_default (fun () -> 0) in + + let rec aux path = + let subdirs = Common2.readdir_to_dir_list path +> List.sort compare in + + subdirs +> List.iter (fun dir -> + let path = Filename.concat path dir in + + if Hashtbl.mem h dir + then begin + pr2 (spf "duplicate dir for %s already there: %s" + dir (Hashtbl.find h dir)); + dups#update dir (fun old -> old + 1); + end else begin + Hashtbl.add h dir path; + end; + aux path + ); + in + aux dir; + pr2 "duplicate are:"; + dups#to_list +> Common.sort_by_val_highfirst +> List.iter (fun (dir,cnt) -> + pr2 (spf " %s: %d" dir cnt); + ); + () + +(*****************************************************************************) +(* actions *) +(*****************************************************************************) + +(* +let actions () = [ + "-test_dup_dir", "", + Common.mk_action_1_arg (find_duplicate_dirname); +] +*) diff --git a/h_program-lang/archi_code.mli b/h_program-lang/archi_code.mli new file mode 100644 index 0000000..6ec609f --- /dev/null +++ b/h_program-lang/archi_code.mli @@ -0,0 +1,31 @@ + +type source_archi = + | Main | Init + | Interface + | Test | Logging + | Core | Utils + | Constants | GetSet + | Configuration | Building | Data + | Doc + + | Ui | Storage | Parsing | Security | I18n + | Architecture | OS | Network + + | Ffi | ThirdParty | Legacy + | AutoGenerated | BoilerPlate + + | Unittester | Profiler + | MiniLite | Intern + | Script + + | Regular +val s_of_source_archi: source_archi -> string + +val source_archi_list: source_archi list + +type source_kind = + | Header + | Source + +(* can tell you about architecture, and also about design pbs *) +val find_duplicate_dirname: Common.dirname -> unit diff --git a/h_program-lang/archi_code_lexer.mll b/h_program-lang/archi_code_lexer.mll new file mode 100644 index 0000000..54fc279 --- /dev/null +++ b/h_program-lang/archi_code_lexer.mll @@ -0,0 +1,517 @@ +{ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Archi_code + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(* This code assumes we are called with a string enclosed by "/" + * as in /foo.php/ so it's easy to specify the beginning or + * end of a string (ocamllex does not handle ^ or $). + * + * It also assumes the string has been lowercased. Note also that + * the filenames has been reversed, for instance a/b/foo.php becomes + * /foo.php/b/a/ because we want to return the most specialized category. + * update: now we first run the lexer on the lowecased basename and + * then separately on the dirname. + * + * Note that ocamllex will try the longest match and we will return + * the leftmost match so on "common.mli" for instance the + * "common" rule will be applied before the .mli rule. + *) + +} + +let b = ['/' '_' '-' '.'] + +(*****************************************************************************) + +rule category = parse + | ".vcproj/" { Building } + | ".thrift/" { Ffi } + + (* pad specific, noweb *) + | ".nw/" + { Doc } + + | ".texi/" + { Doc } + + | ".pdf/" + | ".rtf/" + { Doc } + + | ".sql/" + { Storage } + + | ".mli/" + | ".h/" + | ".hpp/" + | ".hrl/" + { Interface } + + (* ml specific *) + | ".depend" { Building } + | "ocamlmakefile" { BoilerPlate } + (* oasis boilerplate *) + | "setup.ml" { BoilerPlate } + (* ocamlbuild boilerplate *) + | "/_build" { BoilerPlate } + + | "makefile" + | "/configure" + { Building } + + (* linux specific *) + | "kconfig" { Building } + + | "/changes" { Doc } + | "readme" { Doc } + + | "/license" + | "/copyright" + | b "copying" + { BoilerPlate } + + (* gnu software boilerplate *) + | "/copying/" + | "/about-nls/" + | "/shtool/" + | "/texinfo.tex/" + | "/ltmain.sh/" + { BoilerPlate } + + + + (* pad specific ? *) + | "/main_" { Main } + | "/flag_" { Configuration } + | "/test_" { Test } + | "/unit_" { Test } + | "/visitor_" { AutoGenerated } + | "/meta_ast_" { AutoGenerated } + | "generated" { AutoGenerated } + + (* facebook specific *) + | "/autoload_map" { AutoGenerated } + + + | "/main." { Main } + | "/init." { Init } + + | "/init/" { Init } + + (* facebook specific *) + | "/home.php" { Main } + | "/profile.php" { Main } + + | "/alite/" { Init } + | "/urimaps/" { Init } + + + | "core" { Core } +(* | "/base" { Core } *) + + | "mysql" + | "sqlite" + { Storage } + + | "database" { Storage } + + | "security" { Security } + +(* too many false positives, like mini in mono + | "mini" { MiniLite } + | "lite" { MiniLite } +*) + + | b "tests" b + | "/test/" + | "/test2/" + | "/t/" + | "/_test" + | "/testsuite/" + (* gnugo *) + | "/regression" + { Test } + + | "/benchmarks" + { Test } + + | "/example" + { Test } + | "dummy" + { Test } + | "/demos" + { Test } + + (* facebook specific a little *) + | "/__tests__/" { Test } + + (* pad specific *) + | "pleac" { Test } + + | "/docs/" + | "/doc/" + { Doc } + + | "/unittest/" { Unittester } + (* can not just say "profil" because at facebook profile means + * something else + *) + | "profiling" { Profiler } + + (* False positif for util below *) + | "binutils" + | "coreutils" + | "diffutils" + | "findutils" + | "inetutils" + { Regular } + +(* | "stdlib" { Core } *) + | "util" { Utils } +(* | "/base" { Utils } *) + | "common" { Utils } + (* Exact "lib", Utils; *) + + | "/conf/haste/" { AutoGenerated } + + (* Can not say just thrift here because we could also want + * to look at the thrift source itself. So really just + * want to hide all generated code. + * + * The code is actually in thrift/packages but because the filename + * is reverse, it's /packages/thrift/ here + *) + | "/packages/thrift/" { AutoGenerated } + + | "/thriftdoc/" { AutoGenerated } + + (* thrift auto generated files *) + | "/gen-" { AutoGenerated } + (* for some projects I don't remember *) + | "/gen/" { AutoGenerated } + (* in android dalvik *) + | "/out/" { AutoGenerated } + + + | "storage" + | "/db/" + | "/fs/" + | "/database/" + + (* pad specific ... *) + | "bdb/" + { Storage } + + (* Exact "data", Storage; *) + | "constants" { Constants } + | "mutators" + | "accessors" + { GetSet } + + | "logging" { Logging } + + | "third-party" + | "third_party" + | "3rdparty" + { ThirdParty } + + | "external" { ThirdParty } + | "legacy" { ThirdParty } + (* opam src *) + | "src_ext" { ThirdParty } + | "deprecated" { Legacy } + | "/attic/" { Legacy } + + | "/out/" { Legacy } + + (* pad specfic *) + | "ocamlextra" { ThirdParty } + | "/score_parsing" { Data } + | "/score_tests" { Data } + | "/archive.org" { Data } + + (* facebook fbcode fsl specifix ... *) + | "test.txt" { Data } + | "twl06.txt" { Data } + | "wordlist.gz" { AutoGenerated } + | "/big/" { Data } + + | "/data/" { Data } +(* in haskell this is a valid dir + | "/data/" { Data } +*) + + + (* facebook specific ? *) + | "/si/" + | "site_integrity" + { Security } + + | "/auth" b + { Security } + + (* as in OCaml asmcomp/ directory *) + | "x86" + | "i386" + | "i686" + + | "ia64" + (* v8 source *) + | "ia32" + | b "x64" + + | "mips" + | "m68k" + | "sparc" + | "amd64" + | b "arm" b + | "hppa" + (* linux source *) + | "parisc" + | "s390" + | "blackfin" + | b "ppc" b + | "ppc64" + | "/power/" + | b "powerpc" b + | b "alpha" b + (* gcc source *) + | "rs6000" + | "h8300" + | b "vax" b + | "sh64" + | b "cris" b + | "/frv/" + (* emacs source *) + | "386" + | "hp800" + | "iris4d" + | "macppc" + | "xtensa" + + (* qemu source *) + | b "sh4" b + | "microblaze" + + + + { Architecture } + + (* plan9 source *) + | "/pc/" + | "/alphapc/" + { Architecture } + + | "/arch/" + { Architecture } + + | "unix" + (* commented when analyze linux itself *) + | "linux" + | "macos" + | "win32" + + | "cygwin" + | "msdos" + | b "vms" b + | b "dos/" b + | "mswin" + | "ms-w32" + (* emacs source *) + | b "aix" b + | b "hpux" b + | b "irix" b + | "darwin" + | "freebsd" + | "netbsd" + | "openbsd" + | b "bsd" b + + | b "w32" b + + (* tinyGL *) + | "/beos" + + { OS } + + | "dns" + | "ftp" + | "ssh" + | "http" + | "smtp" + | "ldap" + | b "imap" b (* because can have files like guimap *) + | "krb4" + | "pop3" + | "socks" + | "ssl" + | "socket" + | "mime" + | "url." + | "uri." + | "ipv4" + | "ipv6" + | "icmp." + | "tcp." + { Network } + + (* scan and gram ? too short ? *) + | "scanne" + | "parse" + | "lexer" + | "token" (* false positive with security stuff ? *) + | "/gram." + | "/scan." + | "grammar" + | "/lex" + + (* invent UnParsing category ? do also print ? *) + | "pretty_print" + { Parsing } + + | "/ui/" + | "/gui/" + + (* too many false positives ? *) + | "gui" + + | "display" + | "render" + | "/video/" + | "/media/" + | "screen" + | "visual" + | "image" + | "jpeg" + | "/ui." + | "window" + | "/draw_" + { Ui } + + (* pad specfici ? *) + | "/layer_" + { Ui } + + | "/gtk/" + | "/qt/" + | "/tcltk/" + | "x11" + (* wxwindows. it's also used in efuns, e.g. toolkit/wX_edit.ml *) + | "/wx" + { Ui } + + | "/intern/" { Intern } + + (* overlay specific, because of all those __xxx__ directories *) + | b "intern" b { Intern } + | b "ui/" b + | "/lib__thrift__packages/" { AutoGenerated } + | "/lib__thrift__packages__intern/" { AutoGenerated } + | "/conf/flib__intern__web/haste" { AutoGenerated } + + (* as in Linux *) + | "documentation" { Doc } + (* todo also memory ? so mm/ is colored too *) + | "/net/" { Network } + + | "/old/" + | "/backup/" + { Legacy } + + | "/tmp/" + { Legacy } + + (* i18n *) + + | "/af/" + | "/ar/" + | "/az/" + | "/bg/" + | "/ca/" + | "/ca-valencia/" + | "/cs/" + | "/da/" + | "/de/" + | "/de-informal/" + | "/el/" + (* I keep this one so at least I can see one | "/en/" *) + | "/eo/" + | "/es/" + | "/et/" + | "/eu/" + | "/fa/" + | "/fi/" + | "/fo/" + | "/fr/" + | "/gl/" + | "/he/" + | "/hi/" + | "/hr/" + | "/hu/" +(* | "/ia/", can mean interpreteur abstrait *) + | "/id/" + | "/id-ni/" + | "/is/" + | "/it/" + | "/ja/" + | "/km/" + | "/ko/" + | "/ku/" + | "/lb/" + | "/lt/" + | "/lv/" + | "/mg/" +(* | "/mk/" can be source of mk *) + | "/mr/" + | "/ne/" + | "/nl/" + | "/no/" + | "/pl/" + | "/pt/" + | "/pt-br/" + | "/ro/" + | "/ru/" + | "/sk/" + | "/sl/" + | "/sq/" + | "/sr/" + | "/sv/" + | "/th/" + | "/tr/" + | "/uk/" +(* plan9 exception mips emulator + | "/vi/" +*) + | "/zh/" + | "/zh-tw/" + | "/la/" + { I18n } + + | "i18n" + | "unicode" + | "gettext" + | "/intl/" + { I18n } + + + | _ { + category lexbuf + } + | eof { Regular } diff --git a/h_program-lang/archi_code_parse.ml b/h_program-lang/archi_code_parse.ml new file mode 100644 index 0000000..0fa2934 --- /dev/null +++ b/h_program-lang/archi_code_parse.ml @@ -0,0 +1,153 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +open Archi_code + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * The "inference" of the architecture category from a filename + * used to be slow. The "parser" used to be a 'match' with a long series + * of '_ when f =~ ...' but it was getting really slow when + * applied on thousands of filenames. Then we provided a fast-path + * for files that do not match any category, but it was still slow + * when most of the files had a category (for instance because + * most of the files in a project are under something like lib/ or intern/). + * Then we used ocamllex and that was fine! + * + * Current stat of -profile on codemap.opt ~/www: + * Archi.source_of_filename : 1.690 sec 112755 count + *) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let (==~) = Common2.(==~) + +let re_c_yaccfile = Str.regexp "\\(.*\\).tab" + +(* coupling: don't forget to extend re_auto_generated below too *) +let is_auto_generated file = + let (d,b,e) = Common2.dbe_of_filename_noext_ok file in + match e with + | "ml"-> + Sys.file_exists (Common2.filename_of_dbe (d,b, "mll")) || + Sys.file_exists (Common2.filename_of_dbe (d,b, "mly")) || + Sys.file_exists (Common2.filename_of_dbe (d,b, "mlb")) + + | "mli" -> + Sys.file_exists (Common2.filename_of_dbe (d,b, "mly")) + + | "tex" -> + Sys.file_exists (Common2.filename_of_dbe (d,b ^ ".tex", "nw")) + + | "info" -> + Sys.file_exists (Common2.filename_of_dbe (d,b, "texi")) + + (* Makefile.in *) + | "in" -> + Sys.file_exists (Common2.filename_of_dbe (d,b, "am")) + + | "c" -> + b =$= "y.tab" || + Sys.file_exists (Common2.filename_of_dbe (d,b, "y")) || + Sys.file_exists (Common2.filename_of_dbe (d,b, "l")) || + (* bigloo (hmm but then conflict with s9 that have s9.c and s9.scm *) + (* Sys.file_exists (Common2.filename_of_dbe (d,b, "scm")) || *) + (if b ==~ re_c_yaccfile + then + let b' = Common.matched1 b in + Sys.file_exists (Common2.filename_of_dbe (d,b', "y")) + else false + ) + + | _ when b = "Makefile" && e = "NOEXT" -> + Sys.file_exists (Common2.filename_of_dbe (d,b, "am")) || + Sys.file_exists (Common2.filename_of_dbe (d,b, "in")) || + Sys.file_exists (Common2.filename_of_dbe (d,"Imakefile", "")) + + | _ -> false + +(* opti: for some fastpath *) +let re_auto_generated = Str.regexp + "\\(.*\\.\\(ml\\|mli\\|tex\\|info\\|in\\|c\\)\\)\\|.*Makefile" + +(*****************************************************************************) +(* Filename->archi *) +(*****************************************************************************) + +let _hmemo_categ_dir = Hashtbl.create 101 + +(* Why taking the root ? Because if the data are in /tmp/data/soft/... then + * you would get the rule for tmp and data :( should not consider + * directories too far away. + * Why not passing a readable path then? Because most of the functions + * in common expect full path, and also because I use file operations + * like Sys.file_exists in is_auto_generated() which is used by this + * function. + *) +let source_archi_of_filename3 ~root file = + + let base = Filename.basename file in + let f = Common.readable ~root file in + + if base ==~ re_auto_generated && is_auto_generated file + then AutoGenerated + else + let b = "/" ^ Common2.lowercase base ^ "/" in + (* we try to give the most specialized category by first considering + * the extension of the file, then its basename, and then its + * directory component starting from the last one (hence the List.rev) + *) + let lexbuf = Lexing.from_string b in + let categ1 = Archi_code_lexer.category lexbuf in + + let d = Filename.dirname f in + (* try the directory, caching the result. + * + * note: should perhaps put (root, d) as the key for the memoized call + * because when we start from a nested dir and go up, + * the root has changed and so what was considered Regular + * could not be considered Intern. But then + * when we click to go down, we can't reuse the cached + * archi and the color may actually change which can be confusing. + * + *) + let categ2 = + Common.memoized _hmemo_categ_dir d (fun () -> + + let d = Common2.lowercase d in + + let xs = Common.split "/" d in + let xs = List.rev xs in + let str = "/" ^ Common.join "/" xs ^ "/" in + + let lexbuf = Lexing.from_string str in + Archi_code_lexer.category lexbuf + ) + in + (match categ1, categ2 with + | _, (Data | AutoGenerated | ThirdParty | Ffi | Legacy) -> categ2 + | Regular, _x -> categ2 + | _, _ -> categ1 + ) + + +let source_archi_of_filename ~root f = + Common.profile_code "Archi.source_of_filename" (fun () -> + source_archi_of_filename3 ~root f) diff --git a/h_program-lang/archi_code_parse.mli b/h_program-lang/archi_code_parse.mli new file mode 100644 index 0000000..7edcb08 --- /dev/null +++ b/h_program-lang/archi_code_parse.mli @@ -0,0 +1,4 @@ + +val source_archi_of_filename: + root:Common.dirname -> + Common.filename -> Archi_code.source_archi diff --git a/h_program-lang/ast_fuzzy.ml b/h_program-lang/ast_fuzzy.ml new file mode 100644 index 0000000..00916ed --- /dev/null +++ b/h_program-lang/ast_fuzzy.ml @@ -0,0 +1,288 @@ +(* Yoann Padioleau + * + * Copyright (C) 2013 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * When searching for or refactoring code, regexps are good enough most of + * the time; tools such as 'grep' or 'sed' are great. But certain regexps + * are tedious to write when one needs to handle variations in spacing, + * the possibilty to have comments in the middle of the code you + * are looking for, or newlines. Things are even more complicated when + * you want to handle nested parenthesized expressions or statements. This is + * because regexps can't count. For instance how would you + * remove a namespace in C++? You would like to write a transformation + * like: + * + * - namespace my_namespace { + * ... + * - } + * + * but regexps can't do that[1]. + * + * The alternative is then to use more precise tools such as 'sgrep' + * or 'spatch'. But implementing sgrep/spatch in the usual way + * for a new language, by matching AST against AST, can be really tedious. + * The AST can be big and even if we can auto generate most of the + * boilerplate code, this still takes quite some effort (see lang_php/matcher). + * + * Moreover, in my experience matching AST against AST lacks + * flexibility sometimes. For instance many people want to use 'sgrep' to + * find a method foo and so do "sgrep -e 'foo(...)'" but + * because the matching is done at the AST level, 'foo(...)' is + * parsed as a function call, not a method call, and so it will + * not work. But people expect it to work because it works + * with regexps. So 'sgrep' for PHP currently forces people to write this + * pattern '$V->foo(...)'. + * In the same way a pattern like '1' was originally matching + * only expressions, but was not matching static constants because + * again it was a different AST constructor. Actually many + * of the extensions and bugfixes in sgrep_php/spatch_php in + * the last year has been related to this lack of flexibility + * because the AST was too precise. + * + * Enter Ast_fuzzy, a way to factorize most of the needs of + * 'sgrep' and 'spatch' over different programming languages, + * while being more flexible in some ways than having a precise AST. + * It fills a niche between regexps and very-precise ASTs. + * + * In Ast_fuzzy we just want to keep the parenthesized information + * from the code, and abstract away spacing, the main things that + * regexps have troubles with, and then let people match over this + * parenthesized cleaned-up tree in a flexible way. + * + * related: + * - xpath? but do programming languages need the full power of xpath? + * usually an AST just have 3 different kinds of nodes, Defs, Stmts, + * and Exprs. + * + * See also lang_cpp/parsing_cpp/test_parsing_cpp and its parse_cpp_fuzzy() + * and dump_cpp_fuzzy() functions. Most of the code related to Ast_fuzzy + * is in matcher/ and called from 'sgrep' and 'spatch'. + * For 'sgrep' and 'spatch' examples, see unit_matcher.ml as well as + * tests/cpp/sgrep/ and tests/cpp/spatch/ + * + * notes: + * [1] Actually Perl regexps are more powerful so one can do for instance: + * echo 'something< namespace>>, other >' | + * perl -pe 's/namespace(<(?:[^<>]|(?1))*>)/foo/' + * => 'something< foo, other >' + * but it's arguably more complicated than the proposed spatch above. + * + * todo: + * - handle infix operators: parse them not as a sequence + * but as a tree as we want for instance '$X->foo()' to match + * whole expression like 'this->bar()->foo()', or we want + * '$X' to match '1+1' (and not only in Parens context) + * - same for function calls? so maybe we need to transform our + * original program in a lisp like AST where things are more uniform + * - how to handle isomorphisms like 'order of attributes don't matter' + * as in XHP? or class that can be mentioned anywhere in the arguments + * to implements? or how can we make 'class X { ... }' to also match + * 'class X extends whatever { ... }'? or have public/static to + * be optional? + * Use regexp over trees? Use isomorphisms file as in coccinelle? + * Have special mark about optional things in ast_fuzzy? + * Derives such information from the grammar? + * - want powerful queries like + * 'class X { ... function(...) { ... foo() ... } ... } + * so sgrep powerful for microlevel queries, and prolog for macrolevel + * queries. Xpath? Css selector? + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type tok = Parse_info.info +type 'a wrap = 'a * tok + +type tree = + | Braces of tok * trees * tok + (* todo: comma *) + | Parens of tok * (trees, tok (* comma*)) Common.either list * tok + | Angle of tok * trees * tok + + (* note that gcc allows $ in identifiers, so using $ for metavariables + * means we will not be able to match such identifiers. No big deal. + *) + | Metavar of string wrap + (* note that "..." are allowed in many languages, so using "..." + * to represent a list of anything means we will not be able to + * match specifically "...". + *) + | Dots of tok + + | Tok of string wrap +and trees = tree list + (* with tarzan *) + +let is_metavar s = + s =~ "^\\$.*" + +(*****************************************************************************) +(* Visitor *) +(*****************************************************************************) + +type visitor_out = trees -> unit + +type visitor_in = { + ktree: (tree -> unit) * visitor_out -> tree -> unit; + ktrees: (trees -> unit) * visitor_out -> trees -> unit; + ktok: (tok -> unit) * visitor_out -> tok -> unit; +} + +let (default_visitor : visitor_in) = + { ktree = (fun (k, _) x -> k x); + ktok = (fun (k, _) x -> k x); + ktrees = (fun (k, _) x -> k x); + } + +let (mk_visitor: visitor_in -> visitor_out) = fun vin -> + + let rec v_tree x = + let k x = match x with + | Braces ((v1, v2, v3)) -> + let _v1 = v_tok v1 and _v2 = v_trees v2 and _v3 = v_tok v3 in () + | Parens ((v1, v2, v3)) -> + let _v1 = v_tok v1 + and _v2 = Ocaml.v_list (Ocaml.v_either v_trees v_tok) v2 + and _v3 = v_tok v3 + in () + + | Angle ((v1, v2, v3)) -> + let _v1 = v_tok v1 and _v2 = v_trees v2 and _v3 = v_tok v3 in () + | Metavar v1 -> let _v1 = v_wrap v1 in () + | Dots v1 -> let _v1 = v_tok v1 in () + | Tok v1 -> let _v1 = v_wrap v1 in () + in + vin.ktree (k, all_functions) x + and v_trees a = + let k xs = + match xs with + | [] -> () + | x::xs -> + v_tree x; + v_trees xs; + in + vin.ktrees (k, all_functions) a + + and v_wrap (_s, x) = v_tok x + + and v_tok x = + let k _x = () in + vin.ktok (k, all_functions) x + + and all_functions x = v_trees x in + all_functions + +(*****************************************************************************) +(* Map *) +(*****************************************************************************) + +type map_visitor = { + mtok: (tok -> tok) -> tok -> tok; +} + +let (mk_mapper: map_visitor -> (trees -> trees)) = fun hook -> + let rec map_tree = + function + | Braces ((v1, v2, v3)) -> + let v1 = map_tok v1 + and v2 = map_trees v2 + and v3 = map_tok v3 + in Braces ((v1, v2, v3)) + | Parens ((v1, v2, v3)) -> + let v1 = map_tok v1 + and v2 = List.map (Ocaml.map_of_either map_trees map_tok) v2 + and v3 = map_tok v3 + in Parens ((v1, v2, v3)) + | Angle ((v1, v2, v3)) -> + let v1 = map_tok v1 + and v2 = map_trees v2 + and v3 = map_tok v3 + in Angle ((v1, v2, v3)) + | Metavar v1 -> let v1 = map_wrap v1 in Metavar ((v1)) + | Dots v1 -> let v1 = map_tok v1 in Dots ((v1)) + | Tok v1 -> let v1 = map_wrap v1 in Tok ((v1)) + and map_trees v = List.map map_tree v + and map_tok v = + let k v = v in + hook.mtok k v + and map_wrap (s, t) = (s, map_tok t) + in + map_trees + +(*****************************************************************************) +(* Extractor *) +(*****************************************************************************) + +let (toks_of_trees: trees -> Parse_info.info list) = fun trees -> + let globals = ref [] in + let hooks = { default_visitor with + ktok = (fun (_k, _) i -> Common.push i globals) + } in + begin + let vout = mk_visitor hooks in + vout trees; + List.rev !globals + end + +(*****************************************************************************) +(* Abstract position *) +(*****************************************************************************) + +let abstract_position_trees trees = + let hooks = { + mtok = (fun (_k) i -> + { i with Parse_info.token = Parse_info.Ab } + ) + } in + let mapper = mk_mapper hooks in + mapper trees + +(*****************************************************************************) +(* Vof *) +(*****************************************************************************) + +let vof_token t = + Ocaml.VString (Parse_info.str_of_info t) + (* Parse_info.vof_token t*) + +let rec vof_multi_grouped = + function + | Braces ((v1, v2, v3)) -> + let v1 = vof_token v1 + and v2 = Ocaml.vof_list vof_multi_grouped v2 + and v3 = vof_token v3 + in Ocaml.VSum (("Braces", [ v1; v2; v3 ])) + | Parens ((v1, v2, v3)) -> + let v1 = vof_token v1 + and v2 = Ocaml.vof_list (Ocaml.vof_either vof_trees vof_token) v2 + and v3 = vof_token v3 + in Ocaml.VSum (("Parens", [ v1; v2; v3 ])) + | Angle ((v1, v2, v3)) -> + let v1 = vof_token v1 + and v2 = Ocaml.vof_list vof_multi_grouped v2 + and v3 = vof_token v3 + in Ocaml.VSum (("Angle", [ v1; v2; v3 ])) + | Metavar v1 -> let v1 = vof_wrap v1 in Ocaml.VSum (("Metavar", [ v1 ])) + | Dots v1 -> let v1 = vof_token v1 in Ocaml.VSum (("Dots", [ v1 ])) + | Tok v1 -> let v1 = vof_wrap v1 in Ocaml.VSum (("Tok", [ v1 ])) +and vof_wrap (s, _x) = Ocaml.VString s +and vof_trees xs = + Ocaml.VList (xs +> List.map vof_multi_grouped) diff --git a/h_program-lang/ast_fuzzy.mli b/h_program-lang/ast_fuzzy.mli new file mode 100644 index 0000000..8d2ad3f --- /dev/null +++ b/h_program-lang/ast_fuzzy.mli @@ -0,0 +1,42 @@ + +type tok = Parse_info.info +type 'a wrap = 'a * tok + +type tree = + | Braces of tok * trees * tok + | Parens of tok * (trees, tok (* comma*)) Common.either list * tok + | Angle of tok * trees * tok + + (* note that gcc allows $ in identifiers, so using $ for metavariables + * means we will not be able to match such identifiers (but no big deal) + *) + | Metavar of string wrap + (* note that "..." are allowed in many languages, so using "..." + * to represent a list of anything means we will not be able to + * match specifically "...". + *) + | Dots of tok + + | Tok of string wrap + +and trees = tree list + +(* see matcher/parse_fuzzy.mli for helpers to build such trees *) + +val is_metavar: string -> bool + +(* visitors, dumpers, extractors, abstractors, mappers *) + +val abstract_position_trees: trees -> trees +val toks_of_trees: trees -> tok list +val vof_trees: trees -> Ocaml.v + +type visitor_out = trees -> unit +type visitor_in = { + ktree: (tree -> unit) * visitor_out -> tree -> unit; + ktrees: (trees -> unit) * visitor_out -> trees -> unit; + ktok: (tok -> unit) * visitor_out -> tok -> unit; +} + +val default_visitor: visitor_in +val mk_visitor: visitor_in -> visitor_out diff --git a/h_program-lang/big_grep.ml b/h_program-lang/big_grep.ml new file mode 100644 index 0000000..892185d --- /dev/null +++ b/h_program-lang/big_grep.ml @@ -0,0 +1,194 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module Db = Database_code + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Inspired by 'tbgs' and big_grep at facebook. + * The trick is to build a giant string and run compiled-regexps + * on it. For each match have to go back to find the start and + * end of entity, or the entity number so can display + * the information associated with it. So need markers + * in the string. + * + * One-liner in perl by Erling: + * perl -e '$|++; open F,"/usr/share/dict/words"; { local $/; $all=; + * } while() { chomp; $w=$_; $n = 0; while($all =~ /$w.*/g) { + * print "$&\n"; last if ++$n>10; } print "[$w]\n"; }' + * + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type index = { + big_string: string; + pos_to_entity: (int, Db.entity) Hashtbl.t; + case_sensitive: bool; +} + +(* using \n is convenient so can allow regexp queries like + * employee.* without having the regexp engine to try to match + * the whole string; it will stop at the first \n. + *) +let separation_marker_char = '\n' + +let empty_index () = { + big_string = ""; + pos_to_entity = Hashtbl.create 1; + case_sensitive = false; +} + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let (==~) = Common2.(==~) + +(*****************************************************************************) +(* Naive version *) +(*****************************************************************************) + +(* This is the naive version, just to have a baseline for benchmarks *) +let naive_top_n_search2 ~top_n ~query xs = + let re = Str.regexp (".*" ^ query) in + + let rec aux ~n xs = + if n = top_n + then [] + else + (match xs with + | [] -> [] + | e::xs -> + if e.Db.e_name ==~ re + then + e::aux ~n:(n+1) xs + else + aux ~n xs + ) + in + aux ~n:0 xs + + +let naive_top_n_search ~top_n ~query idx = + Common.profile_code "Big_grep.naive_top_n" (fun () -> + naive_top_n_search2 ~top_n ~query idx + ) + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +let build_index2 ?(case_sensitive=false) entities = + + let buf = Buffer.create 20_000_000 in + let h = Hashtbl.create 1001 in + + let current = ref 0 in + + entities +> List.iter (fun e -> + (* Use fullname ? The caller, that is for instance + * files_and_dirs_and_sorted_entities_for_completion + * should have done the job of putting the fullename in e_name. + *) + let s = Common2.string_of_char separation_marker_char ^ e.Db.e_name in + let s = + if case_sensitive + then s + else Common2.lowercase s + in + + Buffer.add_string buf s; + Hashtbl.add h !current e; + current := !current + String.length s; + ); + (* just to make it easier to code certain algorithms such as + * find_position_marker_after + *) + Buffer.add_string buf (Common2.string_of_char separation_marker_char); + + { + big_string = Buffer.contents buf; + pos_to_entity = h; + case_sensitive = case_sensitive; + } + +let build_index ?case_sensitive a = + Common.profile_code "Big_grep.build_idx" (fun () -> + build_index2 ?case_sensitive a) + + +let find_position_marker_before start_pos str = + let pos = ref (start_pos - 1) in + + while String.get str !pos <> separation_marker_char do + pos := !pos - 1 + done; + !pos + +let find_position_marker_after start_pos str = + let pos = ref (start_pos + 1) in + + while String.get str !pos <> separation_marker_char do + pos := !pos + 1 + done; + !pos + +(* the query can now contain multipe words *) +let top_n_search2 ~top_n ~query idx = + + let query = + if idx.case_sensitive then query else Common2.lowercase query + in + + let words = Str.split (Str.regexp "[ \t]+") query in + let re = + match words with + | [_] -> Str.regexp (".*" ^ query) + | [a;b] -> + Str.regexp (spf + ".*\\(%s.*%s\\)\\|\\(%s.*%s\\)" + a b b a) + | _ -> + failwith "more-than-2-words query is not supported; give money to pad" + in + + let rec aux ~n ~pos = + if n = top_n + then [] + else + try + let new_pos = Str.search_forward re idx.big_string pos in + (* let's found the marker *) + let pos_mark = + find_position_marker_before new_pos idx.big_string in + let pos_next_mark = + find_position_marker_after new_pos idx.big_string in + let e = Hashtbl.find idx.pos_to_entity pos_mark in + e::aux ~n:(n+1) ~pos:pos_next_mark + with Not_found -> [] + in + aux ~n:0 ~pos:0 + + +let top_n_search ~top_n ~query idx = + Common.profile_code "Big_grep.top_n" (fun () -> + top_n_search2 ~top_n ~query idx + ) diff --git a/h_program-lang/big_grep.mli b/h_program-lang/big_grep.mli new file mode 100644 index 0000000..41c6d53 --- /dev/null +++ b/h_program-lang/big_grep.mli @@ -0,0 +1,27 @@ + +type index = { + big_string: string; + pos_to_entity: (int, Database_code.entity) Hashtbl.t; + case_sensitive: bool; +} +val empty_index: unit -> index + +(* the list is supposed to be sorted by importance so that the + * top n search returns first the most important entities + *) +val build_index: + ?case_sensitive:bool -> + Database_code.entity list -> index + +val top_n_search: + top_n:int -> + query:string -> + index -> + Database_code.entity list + +val naive_top_n_search: + top_n:int -> + query:string -> + Database_code.entity list -> + Database_code.entity list + diff --git a/h_program-lang/comment_code.ml b/h_program-lang/comment_code.ml new file mode 100644 index 0000000..6ae5690 --- /dev/null +++ b/h_program-lang/comment_code.ml @@ -0,0 +1,95 @@ +(* Yoann Padioleau + * + * Copyright (C) 2014 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module PI = Parse_info + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * todo: extract and factorize more from comment_php.ml + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* todo: duplicate of matcher/parse_fuzzy.ml *) +type 'tok hooks = { + kind: 'tok -> Parse_info.token_kind; + tokf: 'tok -> Parse_info.info; +} + +(*****************************************************************************) +(* Functions *) +(*****************************************************************************) + + +let comment_before hooks tok all_toks = + let pos = Parse_info.pos_of_info tok in + let before = + all_toks +> Common2.take_while (fun tok2 -> + let info = hooks.tokf tok2 in + let pos2 = PI.pos_of_info info in + pos2 < pos + ) + in + let first_non_space = + List.rev before +> Common2.drop_while (fun t -> + let kind = hooks.kind t in + match kind with + | PI.Esthet PI.Newline | PI.Esthet PI.Space -> true + | _ -> false + ) + in + match first_non_space with + | x::_xs when hooks.kind x =*= PI.Esthet (PI.Comment) -> + let info = hooks.tokf x in + if PI.col_of_info info = 0 + then Some info + else None + | _ -> None + + +let comment_after hooks tok all_toks = + let pos = PI.pos_of_info tok in + let line = PI.line_of_info tok in + let after = + all_toks +> Common2.drop_while (fun tok2 -> + let info = hooks.tokf tok2 in + let pos2 = PI.pos_of_info info in + pos2 <= pos + ) + in + let first_non_space = + after +> Common2.drop_while (fun t -> + let kind = hooks.kind t in + match kind with + | PI.Esthet PI.Newline | PI.Esthet PI.Space -> true + | _ -> false + ) + in + match first_non_space with + | x::_xs when hooks.kind x =*= PI.Esthet (PI.Comment) -> + let info = hooks.tokf x in + (* for ocaml comments they are not necessarily in + * column 0, but they must be just after + *) + if PI.line_of_info info = line || PI.line_of_info info = line + 1 + (* && PI.col_of_info info > 0 *) + then Some info + else None + | _ -> None diff --git a/h_program-lang/comment_code.mli b/h_program-lang/comment_code.mli new file mode 100644 index 0000000..ea8a1ed --- /dev/null +++ b/h_program-lang/comment_code.mli @@ -0,0 +1,11 @@ + +type 'tok hooks = { + kind: 'tok -> Parse_info.token_kind; + tokf: 'tok -> Parse_info.info; +} + +val comment_before: + 'a hooks -> Parse_info.info -> 'a list -> Parse_info.info option + +val comment_after: + 'a hooks -> Parse_info.info -> 'a list -> Parse_info.info option diff --git a/h_program-lang/copyright.txt b/h_program-lang/copyright.txt new file mode 100644 index 0000000..4726911 --- /dev/null +++ b/h_program-lang/copyright.txt @@ -0,0 +1,13 @@ +Copyright (C) 2010 Facebook + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public License (LGPL) + version 2.1 as published by the Free Software Foundation, with the + special exception on linking described in file license.txt. + + This library 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 file + license.txt for more details. + + diff --git a/h_program-lang/coverage_code.ml b/h_program-lang/coverage_code.ml new file mode 100644 index 0000000..8010188 --- /dev/null +++ b/h_program-lang/coverage_code.ml @@ -0,0 +1,156 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module J = Json_type + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * The goal of this module is to provide data structures that can be + * used to mimic the Microsoft Echelon[1] project which given a patch + * try to run the most relevant tests that could be affected by the + * patch. It is probably easier in interpreted languages such as PHP which + * contain simple tracers/profilers. + * + * We can even run the tests and says whether the new code has + * been covered (like in MySql test infrastructure). + * + * For now we just provide types for a mapping from + * a source code file to a list of relevant test files. + * + * References: + * [1] http://research.microsoft.com/apps/pubs/default.aspx?id=69911 + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* relevant test files exercising source, with term-frequency of + * file in the test *) +type tests_coverage = (Common.filename, tests_score) Common.assoc + and tests_score = (Common.filename * float) list + (* with tarzan *) + +(* Note that xdebug by default does not trace assignements but only + * function and method calls, which mean the list of lines returned + * is an under-approximation. We compensate such an approximation by + * also computing the static set of function/method calls so that + * a coverage percentage can be computed. + * + * update: with hphpi tracer, we actually also cover assignement and + * this type is actually independent of such design decision. + * It's line-based though, so don't expect complex path coverage + * or MCDC stuff. Just simple line coverage ... + *) +type lines_coverage = (Common.filename, file_lines_coverage) Common.assoc + and file_lines_coverage = { + covered_sites: int list; + all_sites: int list; + } + (* with tarzan *) + +(*****************************************************************************) +(* String of, json, etc *) +(*****************************************************************************) + +(* This helps generates a coverage file that 'arc unit' can read *) +let (json_of_tests_coverage: tests_coverage -> J.json_type) = fun cov -> + J.Object (cov +> List.map (fun (cover_file, tests_score) -> + cover_file, + J.Array (tests_score +> List.map (fun (test_file, score) -> + J.Array [J.String test_file; J.String (spf "%.3f" score)] + )) + )) + +(* todo: should be autogenerated by ocamltarzan *) +let (tests_coverage_of_json: J.json_type -> tests_coverage) = fun j -> + match j with + | J.Object (xs) -> + xs +> List.map (fun (cover_file, tests_score) -> + cover_file, + match tests_score with + | J.Array zs -> + zs +> List.map (fun test_file_score_pair -> + (match test_file_score_pair with + | J.Array [J.String test_file; J.String str_score] -> + test_file, float_of_string str_score + + | _ -> failwith "Bad json, tests_coverage_of_json" + ) + ) + | _ -> failwith "Bad json, tests_coverage_of_json" + ) + | _ -> failwith "Bad json, tests_coverage_of_json" + +(* todo: should be autogenerated by ocamltarzan *) +let (json_of_lines_coverage: lines_coverage -> J.json_type) = fun cov -> + J.Object (cov +> List.map (fun (file, cover) -> + file, + J.Object ([ + (* I use short fieldnames to avoid generating a huge JSON file. + *) + "cov", J.Array (cover.covered_sites +> List.map (fun l -> J.Int l)); + "all", J.Array (cover.all_sites +> List.map (fun l -> J.Int l)); + ]) + )) + +let (lines_coverage_of_json: J.json_type -> lines_coverage) = fun j -> + match j with + | J.Object (xs) -> + xs +> List.map (fun (file, cover) -> + file, + match cover with + | J.Object ([ + "cov", J.Array covered_lines; + "all", J.Array call_sites; + ]) -> + { + covered_sites = + covered_lines +> List.map (function + | J.Int l -> l + | _ -> failwith "Bad json, files_coverage_of_json" + ); + all_sites = + call_sites +> List.map (function + | J.Int l -> l + | _ -> failwith "Bad json, files_coverage_of_json" + ); + } + | _ -> failwith "Bad json, files_coverage_of_json" + ) + | _ -> failwith "Bad json, files_coverage_of_json" + + +let (save_tests_coverage: tests_coverage -> Common.filename -> unit) = + fun cov file -> + cov +> json_of_tests_coverage +> Json_out.string_of_json + +> Common.write_file ~file + +let (load_tests_coverage: Common.filename -> tests_coverage) = + fun file -> + file +> Json_in.load_json +> tests_coverage_of_json + + +let (save_lines_coverage: lines_coverage -> Common.filename -> unit) = + fun cov file -> + cov +> json_of_lines_coverage +> Json_out.string_of_json + +> Common.write_file ~file + +let (load_lines_coverage: Common.filename -> lines_coverage) = + fun file -> + file +> Json_in.load_json +> lines_coverage_of_json diff --git a/h_program-lang/coverage_code.mli b/h_program-lang/coverage_code.mli new file mode 100644 index 0000000..d7a27f5 --- /dev/null +++ b/h_program-lang/coverage_code.mli @@ -0,0 +1,25 @@ + +(* relevant test files exercising source, with term-frequency of + * file in the test *) +type tests_coverage = (Common.filename (* source *), tests_score) Common.assoc + and tests_score = (Common.filename (* a test *) * float) list + +type lines_coverage = (Common.filename, file_lines_coverage) Common.assoc + and file_lines_coverage = { + covered_sites: int list; + all_sites: int list; + } + +(* input/output *) +val json_of_tests_coverage: tests_coverage -> Json_type.json_type +val json_of_lines_coverage: lines_coverage -> Json_type.json_type + +val tests_coverage_of_json: Json_type.json_type -> tests_coverage +val lines_coverage_of_json: Json_type.json_type -> lines_coverage + +(* shortcuts *) +val save_tests_coverage: tests_coverage -> Common.filename -> unit +val load_tests_coverage: Common.filename -> tests_coverage + +val save_lines_coverage: lines_coverage -> Common.filename -> unit +val load_lines_coverage: Common.filename -> lines_coverage diff --git a/h_program-lang/database_code.ml b/h_program-lang/database_code.ml new file mode 100644 index 0000000..596cc53 --- /dev/null +++ b/h_program-lang/database_code.ml @@ -0,0 +1,698 @@ +(* Yoann Padioleau + * + * Copyright (C) 2009, 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +open Entity_code +module J = Json_type +module HC = Highlight_code + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * This module provides a generic "database" of semantic information + * on a codebase (a la CIA [1]). The goal is to give access to + * information computed by a set of global static or dynamic analysis + * such as 'what are the number of callers to a certain function', 'what + * is the test coverage of a file', etc. This is mainly used by codemap + * to give semantic visual feedback on the code. See also layer_code.ml + * for complementary semantic information about a codebase. + * + * update: prolog_code.pl and Prolog may now be the prefered way to + * represent a code database, but for codemap it's still good to use + * this database. + * + * Each programming language analysis library usually provides + * a more powerful database (e.g. analyze_php/database/database_php.mli) + * with more information. Such a database is usually also efficiently stored + * on disk via BerkeleyDB. Nevertheless generic tools like + * codemap can benefit from a shorter and generic version of this + * database. Moreover, when we have codebase with multiple langages + * (e.g. PHP and javascript), having a common type can help for some + * analysis or visualization. + * + * Note that by storing this toy database in a JSON format or with Marshall, + * this database can also easily be read by multiple + * process at the same time (there is currently a few problems with + * concurrent access of Berkeley Db data; for instance one database + * created by a user can not even be read by another user ...). + * This also avoids forcing the user to spend time running all + * the global analysis on his own codebase. We can factorize the essential + * results of such long computation in a single file. + * + * An alternative would be to use the TAGS file or information from + * cscope. But this would require to implement a reader for those + * two formats. Moreover ctags/cscope do just lexical-based analysis + * so it's not a good basis and it contains only defition->position + * information. + * + * history: + * - started when working for eurosys'06 in patchparse/ in a file called + * c_info.ml + * - extended for eurosys'08 for coccinelle/ in coccinelle/extra/ + * and use it to discover some .c .h mapping and generate some crazy + * graphs and also to detect drivers splitted in multiple files. + * - extended it for aComment in 2008 and 2009, to feed information to some + * inter-procedural analysis. + * - rewrite it for PHP in Nov 2009 + * - adapted in Jan 2010 for flib_navigator + * - make it generic in Aug 2010 for my code/treemap visualizer + * - added comments about Prolog database which may be a better db for + * certain use cases. + * + * history bis: + * - Before, I was optimizing stuff by caching the ast in + * some xxx_raw files. But there was lots of small raw files; + * get lots of ast files and waste space. Also not good for random + * access to the asts. So better to use berkeley DB. My experience with + * LFS helped me a little as I was already using berkeley DB and glimpse. + * + * - I was also using glimpse and I tried to accelerate even more coccinelle + * to generate some mini C files so that glimpse can directly tell us + * the toplevel elements to look for. But this generates lots of + * very small mini C files which also waste lots of disk space. + * + * References: + * [1] CIA, the C Information Abstractor + *) + +(*****************************************************************************) +(* Type *) +(*****************************************************************************) + +(* How to store the id of an entity ? A int ? A name and hope few conflicts ? + * Using names will increase the size of the db which will slow down + * the loading of the database. + * So it's better to use an id. Moreover at some point we want to provide + * callers/callees navigations and more entities relationships + * so we need a real way to reference an entity. + *) +type entity_id = int + +type entity = { + e_kind: entity_kind; + + e_name: string; + (* can be empty to save space when e_fullname = e_name *) + e_fullname: string; + + e_file: Common.filename; + e_pos: Common2.filepos; + + (* Semantic information that can be leverage by a code visualizer. + * The fields are set as mutable because usually we compute + * the set of all entities in a first phase and then we + * do another pass where we adjust numbers of other entity references. + *) + + (* todo: could give more importance when used externally not just + * from another file but from another directory! + * or could refine this int with more information. + *) + mutable e_number_external_users: int; + + (* Usually the id of a unit test of pleac file. + * + * Indeed a simple algorithm to compute this list is: + * just look at the callers, filter the one in unit test or pleac files, + * then for each caller, look at the number of callees, and take + * the one with best ratio. + * + * With references to good examples of use, we can offer + * what Perl programmers had for years with their function + * documentations. + * If there is no examples_of_use then the user can visually + * see that some functions should be unit tested :) + *) + mutable e_good_examples_of_use: entity_id list; + + (* todo? code_rank ? this is more useful for number_internal_users + * when we want to know what is the core function in a module, + * even when it's called only once, but by a small wrapper that is + * itself very often called. + *) + + e_properties: property list; + } + +(* Note that because we now use indexed entities, you can not + * play with.entities as before. For instance merging databases + * requires to adjust all the entity_id internal references. + *) +type database = { + + (* The common root if the database was built with multiple dirs + * as an argument. Such a root is mostly useful when displaying + * filenames in which case we can strip the root from it + * (e.g. in the treemap browser when we mouse over a rectangle). + *) + root: Common.dirname; + + (* Such list can be used in a search box powered by completion. + * The int is for the total number of times this files is + * externally referenced. Can be use for instance in the treemap + * to artificially augment the size of what is probably a more + * "important" file. + *) + dirs: (Common.filename * int) list; + + (* see also build_top_k_sorted_entities_per_file for dynamically + * computed summary information for a file + *) + files: (Common.filename * int) list; + + (* indexed by entity_id *) + entities: entity array; +} + +let empty_database () = { + root = ""; + dirs = []; + files = []; + entities = Array.of_list []; +} + +let default_db_name = + "PFFF_DB.marshall" + + +(*****************************************************************************) +(* Json *) +(*****************************************************************************) + +(*---------------------------------------------------------------------------*) +(* json -> X *) +(*---------------------------------------------------------------------------*) + +let json_of_filepos x = + J.Array [J.Int x.Common2.l; J.Int x.Common2.c] + +let json_of_property x = + match x with + | ContainDynamicCall -> J.Array [J.String "ContainDynamicCall"] + | ContainReflectionCall -> J.Array [J.String "ContainReflectionCall"] + | TakeArgNByRef i -> J.Array [J.String "TakeArgNByRef"; J.Int i] + | _ -> raise Todo + +let json_of_entity e = + J.Object [ + "k", J.String (string_of_entity_kind e.e_kind); + "n", J.String e.e_name; + "fn", J.String e.e_fullname; + "f", J.String e.e_file; + "p", json_of_filepos e.e_pos; + (* different from type *) + "cnt", J.Int e.e_number_external_users; + "u", J.Array (e.e_good_examples_of_use +> List.map (fun id -> J.Int id)); + "ps", J.Array (e.e_properties +> List.map json_of_property); + ] + +let json_of_database db = + J.Object [ + "root", J.String db.root; + "dirs", J.Array (db.dirs +> List.map (fun (x, i) -> + J.Array([J.String x; J.Int i]))); + "files", J.Array (db.files +> List.map (fun (x, i) -> + J.Array([J.String x; J.Int i]))); + "entities", J.Array (db.entities +> + Array.to_list +> List.map json_of_entity); + ] + +(*---------------------------------------------------------------------------*) +(* X -> json *) +(*---------------------------------------------------------------------------*) +let ids_of_json json = + match json with + | J.Array xs -> + xs +> List.map (function + | J.Int id -> id + | _ -> failwith "bad json" + ) + | _ -> failwith "bad json" + +let filepos_of_json json = + match json with + | J.Array [J.Int l; J.Int c] -> + { Common2.l = l; Common2.c = c } + | _ -> failwith "Bad json" + +let property_of_json json = + match json with + | J.Array [J.String "ContainDynamicCall"] -> ContainDynamicCall + | J.Array [J.String "ContainReflectionCall"] -> ContainReflectionCall + | J.Array [J.String "TakeArgNByRef"; J.Int i] -> TakeArgNByRef i + | _ -> failwith "property_of_json: bad json" + + +let properties_of_json json = + match json with + | J.Array xs -> + xs +> List.map property_of_json + | _ -> failwith "Bad json" + +(* Reverse of json_of_entity_info; must follow same convention for the order + * of the fields. + *) +let entity_of_json2 json = + match json with + | J.Object [ + "k", J.String e_kind; + "n", J.String e_name; + "fn", J.String e_fullname; + "f", J.String e_file; + "p", e_pos; + (* different from type *) + "cnt", J.Int e_number_external_users; + "u", ids; + "ps", properties; + ] -> { + e_kind = entity_kind_of_string e_kind; + e_name = e_name; + e_file = e_file; + e_fullname = e_fullname; + e_pos = filepos_of_json e_pos; + e_number_external_users = e_number_external_users; + e_good_examples_of_use = ids_of_json ids; + e_properties = properties_of_json properties; + } + | _ -> failwith "Bad json" + +let entity_of_json a = + Common.profile_code "Db.entity_of_json" (fun () -> + entity_of_json2 a) + + +let database_of_json2 json = + match json with + | J.Object [ + "root", J.String db_root; + "dirs", J.Array db_dirs; + "files", J.Array db_files; + "entities", J.Array db_entities; + ] -> { + root = db_root; + + dirs = db_dirs +> List.map (fun json -> + match json with + | J.Array([J.String x; J.Int i]) -> + x, i + | _ -> failwith "Bad json" + ); + + files = db_files +> List.map (fun json -> + match json with + | J.Array([J.String x; J.Int i]) -> + x, i + | _ -> failwith "Bad json" + ); + entities = + db_entities +> List.map entity_of_json +> Array.of_list + } + + | _ -> failwith "Bad json" + +let database_of_json json = + Common.profile_code "Db.database_of_json" (fun () -> + database_of_json2 json + ) + +(*****************************************************************************) +(* Load/Save *) +(*****************************************************************************) + +let load_database2 file = + pr2 (spf "loading database: %s" file); + if File_type.is_json_filename file + then + (* This code is mostly obsolete. It's more efficient to use Marshall + * to store big database. This should be used only when + * one wants to have a readable database. + *) + let json = + Common.profile_code "Json_in.load_json" (fun () -> + Json_in.load_json file + ) in + database_of_json json + else Common2.get_value file + +let load_database file = + Common.profile_code "Db.load_db" (fun () -> load_database2 file) + +(* We allow to save in JSON format because it may be useful to let + * the user edit read the generated data. + * + * less: could use the more efficient json pretty printer, but really + * marshall is probably better. Only biniou could be a valid alternative. + *) +let save_database database file = + if File_type.is_json_filename file + then + database +> json_of_database + +> Json_io.string_of_json ~compact:false ~recursive:false ~allow_nan:true + +> Common.write_file ~file + else Common2.write_value database file + + +(*****************************************************************************) +(* Entities categories *) +(*****************************************************************************) + +(* coupling: if you add a new kind of entity, then + * don't forget to modify size_font_multiplier_of_categ in code_map/ + * + * How sure this list is exhaustive ? C-c for usedef2 + *) +let entity_kind_of_highlight_category_def categ = + match categ with + | HC.Entity (kind, HC.Def2 _) -> Some kind + + | HC.FunctionDecl _ -> Some Prototype + | HC.StaticMethod (HC.Def2 _) -> Some Method + | HC.StructName (HC.Def) -> Some Type + + (* todo: what about other Def ? like Label, Parameter, etc ? *) + | _ -> None + +let is_entity_def_category categ = + entity_kind_of_highlight_category_def categ <> None + +(* less: merge with other function? *) +let entity_kind_of_highlight_category_use categ = + match categ with + | HC.Entity (kind, HC.Use2 _) -> Some kind + | HC.FunctionDecl _ -> Some Function + | HC.StaticMethod (HC.Use2 _) -> Some Method + | HC.StructName HC.Use -> Some Class + | _ -> None + + +let matching_def_short_kind_kind short_kind kind = + (match short_kind, kind with + (* Struct/Union are generated as Type for now in graph_code_clang.ml *) + | Class, Type -> true + | Global, GlobalExtern -> true + | Function, Prototype -> true + | a, b -> a =*= b + ) + +(* See the code of the different highlight_code_xxx.ml to + * know the different possible pairs. + * todo: merge with other functions too? + *) +let matching_use_categ_kind categ kind = + match kind, categ with + | kind1, HC.Entity (kind2, _) when kind1 =*= kind2 -> true + + | Prototype, HC.Entity (Function, _) + | Constructor, HC.ConstructorMatch _ + | GlobalExtern, HC.Entity (Global, _) + | Method, HC.StaticMethod _ + | ClassConstant, HC.Entity (Constant, _) + + (* tofix at some point, wrong tokenizer *) + | Constant, HC.Local _ + | Global, HC.Local _ + | Function, HC.Local _ + | Constructor, HC.Entity (Global, _) + | Function, HC.Builtin + | Function, HC.BuiltinCommentColor + | Function, HC.BuiltinBoolean + (* because what looks like a constant is actually a partially applied func *) + | Function, HC.Entity (Constant, _) + + (* function pointers in structure initialized (poor's man oo in C) *) + | Function, HC.Entity (Global, _) + (* function calls to pointer function via direct syntax *) + | GlobalExtern, HC.Entity (Function, _) + + | Global, HC.UseOfRef + | Field, HC.UseOfRef + -> true + + | _ -> false + + + +(* In database_light_xxx we sometimes need, given a 'use', to increment + * the e_number_external_users counter of an entity. Nevertheless + * multiple entities may have the same name in which case looking + * for an entity in the environment will return multiple + * entities of different kinds. Here we filter back the + * non valid entities. + *) +let entity_and_highlight_category_correpondance entity categ = + let entity_kind_use = + Common2.some (entity_kind_of_highlight_category_use categ) in + entity.e_kind = entity_kind_use + +(*****************************************************************************) +(* Misc *) +(*****************************************************************************) + +(* When we compute the light database for a language we usually start + * by calling a function to get the set of files in this language + * (e.g. Lib_parsing_ml.find_all_ml_files) and then "infer" + * the set of directories used by those files by just calling dirname + * on them. Nevertheless in the search box of the visualizer we + * want to propose for instance flib/herald even if there is no + * php file in flib/herald but files in flib/herald/lib/foo.php. + * Having flib/herald/lib is not enough. Enter alldirs_and_parent_dirs_of_dirs + * which will compute all the directories. + * + * It's a kind of 'find -type d' but reversed, using a set of complete dirs + * as the starting point. In fact we could define a + * Common.dirs_of_dirs but then directory without any interesting files + * would be listed. + *) +let alldirs_and_parent_dirs_of_relative_dirs dirs = + dirs + +> List.map Common2.inits_of_relative_dir + +> List.flatten +> Common2.uniq_eff + + +let merge_databases db1 db2 = + (* assert same root ?then can just add the fields *) + if db1.root <> db2.root + then begin + pr2 (spf "merge_database: the root differs, %s != %s" + db1.root db2.root); + if not (Common2.y_or_no "Continue ?") + then failwith "ok we stop"; + end; + + (* entities now contain references to other entities through + * the index to the entities array. So concatenating 2 array + * entities requires care. + *) + let length_entities1 = Array.length db1.entities in + + let db2_entities = db2.entities in + let db2_entities_adjusted = + db2_entities +> Array.map (fun e -> + { e with + e_good_examples_of_use = + e.e_good_examples_of_use + +> List.map (fun id -> id + length_entities1); + } + ) + in + + { + root = db1.root; + dirs = (db1.dirs @ db2.dirs) + +> Common.group_assoc_bykey_eff + +> List.map (fun (file, xs) -> + file, Common2.sum xs + ); + files = db1.files @ db2.files; (* should ensure exclusive ? *) + entities = Array.append db1.entities db2_entities_adjusted; + } + + +let build_top_k_sorted_entities_per_file2 ~k xs = + xs + +> Array.to_list + +> List.map (fun e -> e.e_file, e) + +> Common.group_assoc_bykey_eff + +> List.map (fun (file, xs) -> + file, (xs +> List.sort (fun e1 e2 -> + (* high first *) + compare e2.e_number_external_users e1.e_number_external_users + ) +> Common.take_safe k + ) + ) +> Common.hash_of_list + +let build_top_k_sorted_entities_per_file ~k xs = + Common.profile_code "Db.build_sorted_entities" (fun () -> + build_top_k_sorted_entities_per_file2 ~k xs + ) + + +let mk_dir_entity dir n = { + e_name = Common2.basename dir ^ "/"; + e_fullname = ""; + e_file = dir; + e_pos = { Common2.l = 1; c = 0 }; + e_kind = Dir; + e_number_external_users = n; + e_good_examples_of_use = []; + e_properties = []; +} +let mk_file_entity file n = { + e_name = Common2.basename file; + e_fullname = ""; + e_file = file; + e_pos = { Common2.l = 1; c = 0 }; + e_kind = File; + e_number_external_users = n; + e_good_examples_of_use = []; + e_properties = []; +} + +let mk_multi_dirs_entity name dirs_entities = + let dirs_fullnames = dirs_entities +> List.map (fun e -> e.e_file) in + + { + e_name = name ^ "//"; + (* hack *) + e_fullname = ""; + + (* hack *) + e_file = Common.join "|" dirs_fullnames; + + e_pos = { Common2.l = 1; c = 0 }; + e_kind = MultiDirs; + e_number_external_users = + (* todo? *) + (List.length dirs_fullnames); + e_good_examples_of_use = []; + e_properties = []; + } + +let multi_dirs_entities_of_dirs es = + let h = Hashtbl.create 101 in + es +> List.iter (fun e -> + Hashtbl.add h e.e_name e + ); + let keys = Common2.hkeys h in + keys +> Common.map_filter (fun k -> + let vs = Hashtbl.find_all h k in + if List.length vs > 1 + then Some (mk_multi_dirs_entity k vs) + else None + ) + +let files_and_dirs_database_from_files ~root files = + + (* quite similar to what we first do in a database_light_xxx.ml *) + let dirs = files +> List.map Filename.dirname +> Common2.uniq_eff in + let dirs = dirs +> List.map (fun s -> Common.readable ~root s) in + let dirs = alldirs_and_parent_dirs_of_relative_dirs dirs in + + { root = root; + dirs = dirs +> List.map (fun d -> d, 0); (* TODO *) + files = files +> List.map (fun f -> Common.readable ~root f, 0); (* TODO *) + entities = [| |]; + } + + +let files_and_dirs_and_sorted_entities_for_completion2 + ~threshold_too_many_entities + db + = + let nb_entities = Array.length db.entities in + + let dirs = + db.dirs +> List.map (fun (dir, n) -> mk_dir_entity dir n) + in + let files = + db.files +> List.map (fun (file, n) -> mk_file_entity file n) + in + let multidirs = multi_dirs_entities_of_dirs dirs in + + let xs = + multidirs @ dirs @ files @ + (if nb_entities > threshold_too_many_entities + then begin + pr2 "Too many entities. Completion just for filenames"; + [] + end else + (db.entities +> Array.to_list +> List.map (fun e -> + (* we used to return 2 entities per entity by having + * both an entity with the short name and one with the long + * name, but now that we do a suffix search, no need + * to keep the short one + *) + if e.e_fullname = "" + then e + else { e with e_name = e.e_fullname } + ) + ) + ) + in + + (* note: return first the dirs and files so that when offer + * completion the dirs and files will be proposed first + * (could also enforce this rule when building the gtk completion model). + *) + xs +> List.map (fun e -> + (match e.e_kind with + | MultiDirs -> 100 + | Dir -> 40 + | File -> 20 + | _ -> e.e_number_external_users + ), e + ) +> Common.sort_by_key_highfirst + +> List.map snd + + +let files_and_dirs_and_sorted_entities_for_completion + ~threshold_too_many_entities a = + Common.profile_code "Db.sorted_entities" (fun () -> + files_and_dirs_and_sorted_entities_for_completion2 + ~threshold_too_many_entities a) + + + +(* The e_number_external_users count is not always very accurate for methods + * when we do very trivial class/methods analysis for some languages. + * This helper function can compensate back this approximation. + *) +let adjust_method_or_field_external_users ~verbose entities = + (* phase1: collect all method counts *) + let h_method_def_count = Common2.hash_with_default (fun () -> 0) in + + entities +> Array.iter (fun e -> + match e.e_kind with + | Method | Field -> + let k = e.e_name in + h_method_def_count#update k (Common2.add1) + | _ -> () + ); + + (* phase2: adjust *) + entities +> Array.iter (fun e -> + match e.e_kind with + | Method | Field -> + let k = e.e_name in + let nb_defs = h_method_def_count#assoc k in + if nb_defs > 1 && verbose + then pr2 ("Adjusting: " ^ e.e_fullname); + + let orig_number = e.e_number_external_users in + e.e_number_external_users <- orig_number / nb_defs; + | _ -> () + ); + () diff --git a/h_program-lang/database_code.mli b/h_program-lang/database_code.mli new file mode 100644 index 0000000..dc80354 --- /dev/null +++ b/h_program-lang/database_code.mli @@ -0,0 +1,81 @@ +open Entity_code + +type entity_id = int + +type entity = { + e_kind: entity_kind; + (* needs to be a shortname, e.g. "map", not "List.map", otherwise the + * highlighter (which uses only a lexer/parser) will not enlarge the + * corresponding token in the file. + *) + e_name: string; + e_fullname: string; (* can be empty *) + e_file: Common.filename; + e_pos: Common2.filepos; + mutable e_number_external_users: int; + mutable e_good_examples_of_use: entity_id list; + e_properties: property list; +} + +(* for debugging *) +(* val json_of_entity: entity -> Json_type.t *) + + +(* The dirs and filenames in this database are in readable format + * so one can use the database generated by another user on + * its own repository (this also saves some space in the generated + * JSON file). Only root is in absolute path format. + *) +type database = { + root: Common.dirname; + + (* the int are for the total number of times this file or dir is + * externally referenced. + *) + dirs: (Common.filename * int) list; + files: (Common.filename * int) list; + + entities: entity array; +} + +(* builders *) +val empty_database: unit -> database +val default_db_name: string +(* save either in a (readable) json format or (fast) marshalled form + * depending on the extension of the filename +*) +val load_database: Common.filename -> database +val save_database: database -> Common.filename -> unit +(* when we want to analyze multi-languages projets *) +val merge_databases: database -> database -> database + +(* build database helpers *) +val alldirs_and_parent_dirs_of_relative_dirs: + Common.dirname list -> Common.dirname list +val files_and_dirs_database_from_files: + root:Common.dirname -> Common.filename list -> database +val adjust_method_or_field_external_users: + verbose:bool -> entity array -> unit + +(* for displaying a summary of the important functions in a file *) +val build_top_k_sorted_entities_per_file: + k:int -> entity array -> (Common.filename, entity list) Hashtbl.t + +(* for big grep *) +val files_and_dirs_and_sorted_entities_for_completion: + threshold_too_many_entities:int -> database -> entity list + +(* codemap collaboration, highlighter (lexer/parser) <-> semantic database *) +val entity_kind_of_highlight_category_def: + Highlight_code.category -> entity_kind option +val entity_kind_of_highlight_category_use: + Highlight_code.category -> entity_kind option +val is_entity_def_category: + Highlight_code.category -> bool +val matching_def_short_kind_kind: + entity_kind -> entity_kind -> bool +val matching_use_categ_kind: + Highlight_code.category -> entity_kind -> bool +(* use vs def *) +val entity_and_highlight_category_correpondance: + entity -> Highlight_code.category -> bool diff --git a/h_program-lang/datalog_code.dl b/h_program-lang/datalog_code.dl new file mode 100644 index 0000000..3b33525 --- /dev/null +++ b/h_program-lang/datalog_code.dl @@ -0,0 +1,171 @@ +% -*- prolog -*- +%******************************************************************************* +% Prelude +%******************************************************************************* + +% This file implements a basic context-insensitive pointer analysis. +% Its outputs are the following relations: +% +% point_to(V, M) - variable 'V' may point to abstract memory loc 'M' +% call_edge(INVOKE, TARGET) - invocation site 'INVOKE' calls function 'TARGET' + +% Based upon: Java context-insensitive inclusion-based pointer analysis +% by John Whaley + +% Related work: +% - Andersen, Steengaard, Manuvir Das, Lin, etc +% - bddbddb, DOOP, http://pag-www.gtisc.gatech.edu/chord/user_guide/datalog.html +% - http://blog.jetbrains.com/idea/2009/08/analyzing-dataflow-with-intellij-idea +% - Frama C, CodeSonar, Coverity, ... +% +% note: I always wanted (but was never able to write ...) an interprocedural +% (dataflow) analysis. With Datalog I did it in one day! It's so easy. +% + +% history: +% - I used to have an array_point_to/2 but it can not work, we have to +% unify array and pointers and so point_to and array_point_to + +%******************************************************************************* +% Relations +%******************************************************************************* + +% Abstract memory locations (also called heap objects), are mostly qualified +% symbols (e.g 'main__foo', 'ret_main', '_cst_line2_'): +% - each globals, functions, constants +% - each malloc (context insensitively). will do sensitively later for +% malloc wrappers or maybe each malloc with certain type. (e.g. any Proc) +% so have some form of type sensitivty at least +% - each locals (context insensitively first), when their addresses are taken +% - each fields (field-based, see sep08.pdf lecture, so *.f, not x.*) +% - array element (array insensitive, aggregation) + +% Invocations: line in the file (e.g. '_in_main_line_14_') + +%assign(dest:V, source:V) input +%assign_address (dest:V, source:V) input +%assign_deref(dest:V, source:V) input +%assign_content(dest:V, source:V) input + +%parameter(f:F, z:Z, v:V) +%return(f:F, v:V) +%argument(i:I, z:Z, v:V) +%call_direct(i:I, f:F) +%call_indirect(i:I, v:V) +%call_ret(i:I, v:V) + +%assign_array_elt(dest:V, source:V) input +%assign_array_element_address(dest:V, source:V) input + +%assign_load_field +%assign_field_address +%assign_store_field +%field_point_to?? hmm maybe once we differentiate objects heap +% and not do just *.f + +%******************************************************************************* +% Rules +%******************************************************************************* + +%------------------------------------------------------------------------------- +% Basic +%------------------------------------------------------------------------------- + +% p = &q +point_to(P, Q) :- + assign_address(P, Q). + +% p = q +point_to(P, L) :- + assign(P, Q), + point_to(Q, L). + +% *p = q, given: q -> l, and p -> w => w now points to l +point_to(W, L) :- + assign_deref(P, Q), + point_to(Q, L), + point_to(P, W). + +% p = *q +point_to(P, L) :- + assign_content(P, Q), + point_to(Q, X), + point_to(X, L). +% see here that X is used both as first and second argument of point_to +% because the domain of the variable is included in the domain of abstract +% memory locations. + +%------------------------------------------------------------------------------- +% Arrays insensitive +%------------------------------------------------------------------------------- + +% p = a[...], which is really just equivalent to p = *a for array insensitivty +point_to(P, Q) :- + assign_array_elt(P, A), + point_to(A, AELT), + point_to(AELT, Q). + +% a[...] = q, again similar to *a = q +point_to(AELT, L) :- + assign_array_deref(A, Q), + point_to(Q, L), + point_to(A, AELT). + +% p = &a[...], equivalent to p = a for array insensitivty +point_to(P, AELT) :- + assign_array_element_address(P, A), + point_to(A, AELT). + +%------------------------------------------------------------------------------- +% Field-base sensitive (*.f, not x.* nor x.f) +%------------------------------------------------------------------------------- + +% p = x->fld +point_to(P, L) :- + assign_load_field(P, X, F), + point_to(F, L). + + +% p->fld = x +point_to(F, L) :- + assign_store_field(P, F, X), + point_to(X, L). + +% p = &x->fld +point_to(P, F) :- + assign_field_address(P, X, F). + +%point_to(F, L) :- +% field_point_to(F, L). + + +%------------------------------------------------------------------------------- +% Calls context-insensitive +%------------------------------------------------------------------------------- + +% ret = foo(v1, v2, ...) +assign(PARAM, ARG) :- + parameter(F, IDX, PARAM), + call_edge(I, F), + argument(I, IDX, ARG). +assign(RET, V) :- + return(F, V), + call_edge(I, F), + call_ret(I, RET). + +call_edge(I, F) :- + call_direct(I, F). +% power of mutually recursive analysis! dataflow -> controlflow -> dataflow +call_edge(I, F) :- + call_indirect(I, V), + point_to(V, F). + +%note: heartbleed detection strongly relies on accurate calls though +% function pointers tracking + +%******************************************************************************* +% Postlude +%******************************************************************************* + +point_to(A,B)? +%call_edge(A,B)? diff --git a/h_program-lang/datalog_code.dtl b/h_program-lang/datalog_code.dtl new file mode 100644 index 0000000..c9420d1 --- /dev/null +++ b/h_program-lang/datalog_code.dtl @@ -0,0 +1,218 @@ +# -*- sh -*- # the datalog dialect used by bddbddb is not prolog-mode compliant :( +#******************************************************************************* +# Prelude +#******************************************************************************* + +# This file implements a basic interprocedural context-insensitive +# inclusion-based pointer analysis for C. Its outputs are the following +# relations: +# +# point_to(V, M) - variable 'V' may point to abstract memory loc 'M' +# field_point_to(FIELD, M) - qualified field may point to loc 'M' +# call_edge(INVOKE, TARGET) - invocation site 'INVOKE' calls function 'TARGET' + +# Based upon: Java context-insensitive inclusion-based pointer analysis +# by John Whaley + +# Related work: +# - Andersen, Steengaard, Manuvir Das, Lin, etc +# - bddbddb, DOOP, http://pag-www.gtisc.gatech.edu/chord/user_guide/datalog.html +# - http://blog.jetbrains.com/idea/2009/08/analyzing-dataflow-with-intellij-idea +# - Frama C, CodeSonar, Coverity, ... +# +# note: I always wanted (but was never able to write ...) an interprocedural +# (dataflow) analysis. With Datalog I did it in one day! It's so easy. +# +# TODO: abuse cpp to express context-sensitivity in a generic way +# (like they do in DOOP with logiblox) + +.basedir "data" + +#******************************************************************************* +# Domains +#******************************************************************************* + +# actually for variables, heap alloc, func, globals, address of locals +V 262144 V.map + +F 16384 F.map +N 16384 N.map +I 32768 I.map +Z 256 + +#todo? .bddvarorder N0_F0_I0_M1_M0_V1_V0_T0_Z0_T1_H0_H1 + +#******************************************************************************* +# Relations +#******************************************************************************* + +# Abstract memory locations (also called heap objects), are mostly qualified +# symbols (e.g 'main__foo', 'ret_main', '_cst_line2_'): +# - each globals, functions, constants +# - each malloc (context insensitively). will do sensitively later for +# malloc wrappers or maybe each malloc with certain type. (e.g. any Proc) +# so have some form of type sensitivty at least +# - each locals (context insensitively first), when their addresses are taken +# - each fields (field-based, see sep08.pdf lecture, so *.f, not x.*) +# - array element (array insensitive, aggregation) + +# Invocations: line in the file (e.g. '_in_main_line_14_') + +assign0(dest:V, source:V) inputtuples +assign_address (dest:V, source:V) inputtuples +assign_deref(dest:V, source:V) inputtuples +assign_content(dest:V, source:V) inputtuples + +parameter(f:N, z:Z, v:V) inputtuples +return(f:N, v:V) inputtuples +argument(i:I, z:Z, v:V) inputtuples +call_direct(i:I, f:N) inputtuples +call_indirect(i:I, v:V) inputtuples +call_ret(i:I, v:V) inputtuples +# typing! +var_to_func(v:V, f:N) inputtuples + +assign_array_elt(dest:V, source:V) inputtuples +assign_array_element_address(dest:V, source:V) inputtuples +assign_array_deref(a:V, v:V) inputtuples + +assign_load_field(dest:V, source:V, fld:F) inputtuples +assign_store_field(dest:V, fld:F, source:V) inputtuples +assign_field_address(dest:V, source:V, fld:F) inputtuples +# typing! +field_to_var(fld:F, v:V) inputtuples +#field_point_to?? hmm maybe once we differentiate objects heap +# and not do just *.f + +point_to0(v:V, h:V) inputtuples + +point_to(v:V, h:V) outputtuples +call_edge(i:I, f:N) outputtuples +assign(dest:V, source:V) + +# the data we really care to export +PointingData (v:V, h:V) outputtuples +CallingData (i:I, f:N) outputtuples + + +#******************************************************************************* +# Rules +#******************************************************************************* + +#------------------------------------------------------------------------------- +# Basic +#------------------------------------------------------------------------------- + +point_to(p, q) :- point_to0(p, q). + +# p = &q +point_to(p, q) :- \ + assign_address(p, q). + +# p = q +# (covers regular assignments but also arguments to parameters and return +# to caller, see the assign/2 definition down in this file) +point_to(p, l) :- \ + assign(p, q),\ + point_to(q, l). + +# *p = q, given: q -> l, and p -> w, we can now infer w -> l +point_to(w, l) :- \ + assign_deref(p, q),\ + point_to(q, l),\ + point_to(p, w). + +# p = *q +point_to(p, l) :- \ + assign_content(p, q),\ + point_to(q, x),\ + point_to(x, l). +# see here that X is used both as first and second argument of point_to +# because the domain of the variable is included in the domain of abstract +# memory locations. + +#------------------------------------------------------------------------------- +# Arrays insensitive +#------------------------------------------------------------------------------- + +# p = a[...], which is really just equivalent to p = *a for array insensitivty +point_to(p, q) :- \ + assign_array_elt(p, a),\ + point_to(a, aelt),\ + point_to(aelt, q). + +# a[...] = q, again similar to *a = q +point_to(aelt, l) :- \ + assign_array_deref(a, q),\ + point_to(q, l),\ + point_to(a, aelt). + +# p = &a[...], equivalent to p = a for array insensitivty +point_to(p, aelt) :- \ + assign_array_element_address(p, a),\ + point_to(a, aelt). + + +#------------------------------------------------------------------------------- +# Field-based sensitivity (*.f, not x.* nor x.f) +#------------------------------------------------------------------------------- + +# p = x->fld +point_to(p, l) :- \ + assign_load_field(p, x, f),\ + field_to_var(f, v),\ + point_to(v, l). + + +# p->fld = x +point_to(v, l) :- \ + assign_store_field(p, f, x),\ + field_to_var(f, v), \ + point_to(x, l). + +# p = &x->fld +point_to(p, v) :- \ + assign_field_address(p, x, f),\ + field_to_var(f, v). + +#point_to(F, L) :- +# field_point_to(F, L). + + +#------------------------------------------------------------------------------- +# Calls context-insensitive +#------------------------------------------------------------------------------- + +assign(a, b) :- assign0(a,b). + +# ret = foo(v1, v2, ...) +# (covers regular function calls but also dynamic calls, see call_edge/2 below) +assign(param, arg) :- \ + parameter(f, idx, param),\ + call_edge(i, f),\ + argument(i, idx, arg). + +assign(ret, v) :- \ + return(f, v),\ + call_edge(i, f),\ + call_ret(i, ret). + +call_edge(i, f) :- \ + call_direct(i, f). + +# power of mutually recursive analysis! dataflow -> controlflow -> dataflow +call_edge(i, f) :- \ + call_indirect(i, v),\ + point_to(v, vf),\ + var_to_func(vf, f). + +#note: heartbleed detection strongly relies on accurate tracking of calls +# through function pointers, so this is important! + +#******************************************************************************* +# Postlude +#******************************************************************************* + +# the data we care to export +PointingData (v,h) :- point_to(v,h). +CallingData (i,f) :- call_indirect(i, v), point_to(v, vf), var_to_func(vf, f). diff --git a/h_program-lang/datalog_code.ml b/h_program-lang/datalog_code.ml new file mode 100644 index 0000000..bb2d4f0 --- /dev/null +++ b/h_program-lang/datalog_code.ml @@ -0,0 +1,357 @@ +(* Yoann Padioleau + * + * Copyright (C) 2014 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * See also prolog_code.ml! + * + * datalog engines: + * - toy datalog using lua + * - bddbddb, a scalabe engine! + * - TODO: pydatalog, embedded DSL in python that can import data from + * SQL + * - ciao? xsb? + * - http://www.learndatalogtoday.org/ and datomic.com + * + * TODO: https://yanniss.github.io/points-to-tutorial15.pdf + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* for locals, but also right now for fields, globals, constants, enum, ... *) +type var = string +type func = string +type fld = string + +(* _cst_xxx, _str_line_xxx, _malloc_in_xxx_line, ... *) +type heap = string +(* _in_xxx_line_xxx_col_xxx *) +type callsite = string + +(* mimics datalog_code.dl top comment *) +type fact = + | PointTo of var * heap + + | Assign of var * var + | AssignContent of var * var + | AssignAddress of var * var + + | AssignDeref of var * var + + | AssignLoadField of var * var * fld + | AssignStoreField of var * fld * var + | AssignFieldAddress of var * var * fld + + | AssignArrayElt of var * var + | AssignArrayDeref of var * var + | AssignArrayElementAddress of var * var + + | Parameter of func * int * var + | Return of func * var (* ret_xxx convention *) + | Argument of callsite * int * var + | ReturnValue of callsite * var + | CallDirect of callsite * func + | CallIndirect of callsite * var + +(*****************************************************************************) +(* Meta *) +(*****************************************************************************) + +(* see datalog_code.dl domain *) +type value = + | V of var + | F of fld + | N of func + | I of callsite + | Z of int + +let string_of_value = function + | V x | F x | N x | I x -> x + | Z _ -> raise Impossible + +type _rule = string + +type _meta_fact = + string * value list + +let meta_fact = function + | PointTo (a, b) -> "point_to", [ V a; V b; ] + | Assign (a, b) -> "assign", [ V a; V b; ] + | AssignContent (a, b) -> "assign_content", [ V a; V b; ] + | AssignAddress (a, b) -> "assign_address", [ V a; V b; ] + | AssignDeref (a, b) -> "assign_deref", [ V a; V b; ] + | AssignLoadField (a, b, c) -> "assign_load_field", [ V a; V b; F c ] + | AssignStoreField (a, b, c) -> "assign_store_field", [ V a; F b; V c ] + | AssignFieldAddress (a, b, c) -> "assign_field_address", [ V a; V b; F c ] + | AssignArrayElt (a, b) -> "assign_array_elt", [ V a; V b; ] + | AssignArrayDeref (a, b) -> "assign_array_deref", [ V a; V b; ] + | AssignArrayElementAddress (a, b) -> "assign_array_element_address", [ V a; V b; ] + | Parameter (a, b, c) -> "parameter", [ N a; Z b; V c ] + | Return (a, b) -> "return", [ N a; V b; ] + | Argument (a, b, c) -> "argument", [ I a; Z b; V c ] + | ReturnValue (a, b) -> "call_ret", [ I a; V b; ] + | CallDirect (a, b) -> "call_direct", [ I a; N b; ] + | CallIndirect (a, b) -> "call_indirect", [ I a; V b; ] + + +(*****************************************************************************) +(* Toy datalog *) +(*****************************************************************************) + +let string_of_fact fact = + let str, xs = meta_fact fact in + spf "%s(%s)" str + (xs +> List.map (function + | V x | F x | N x | I x -> spf "'%s'" x + | Z i -> spf "%d" i + ) +> Common.join ", " + ) + +(*****************************************************************************) +(* Bddbddb *) +(*****************************************************************************) + +(* "V", "F", ... *) +type _domain = string + +let domain_of_value = function + | V _ -> "V" + | F _ -> "F" + | N _ -> "N" + | I _ -> "I" + | Z _ -> "Z" + +type _idx = (string (* metadomain*), value Common.hashset) Hashtbl.t + + + +let bddbddb_of_facts facts dir = + let metas = facts +> List.map meta_fact in + + let hvalues = Hashtbl.create 6 in + let hrules = Hashtbl.create 30 in + + (* build sets *) + metas +> List.iter (fun (arule, xs) -> + let listref = + try Hashtbl.find hrules arule + with Not_found -> + let aref = ref [] in + Hashtbl.add hrules arule aref; + aref + in + listref := xs :: !listref; + + xs +> List.iter (fun v -> + let add_v v = + let domain = domain_of_value v in + let hdomain = + try Hashtbl.find hvalues domain + with Not_found -> + let h = Hashtbl.create 10001 in + Hashtbl.add hvalues domain h; + h + in + Hashtbl.replace hdomain v true; + in + add_v v; + (* for field_to_var and var_to_func *) + (match v with + | F s -> add_v (V s) + | N s -> add_v (V s) + | _ -> () + ) + ) + ); + + (* now build integer indexes *) + let domains_idx = + hvalues +> Common.hash_to_list +> List.map (fun (domain, hdomain) -> + let conv = hdomain +> Common.hashset_to_list +> Common.index_list_0 in + domain, ( + conv, conv +> Common.hash_of_list + ) + ) + in + + Common.command2 (spf "rm -f %s/*" dir); + (* generate .map *) + domains_idx +> List.iter (fun (domain, (map, _idx)) -> + if domain <> "Z" + then begin + let file = Filename.concat dir (domain ^ ".map") in + Common.with_open_outfile file (fun (pr_no_nl, _chan) -> + let pr s = pr_no_nl (s ^ "\n") in + + map +> List.iter (fun (v, _int) -> + pr (string_of_value v) + ) + ) + end + ); + + (* generate .tuples *) + hrules +> Common.hash_to_list +> List.iter (fun (arule, xxs) -> + let arule = + match arule with + | "point_to" -> "point_to0" + | "assign" -> "assign0" + | s -> s + in + + let file = Filename.concat dir (arule ^ ".tuples") in + Common.with_open_outfile file (fun (pr_no_nl, _chan) -> + let pr s = pr_no_nl (s ^ "\n") in + + (* todo: header?? *) + (match !xxs with + | [] -> () + | xs::_xxs -> + let hcnt = Hashtbl.create 6 in + pr (spf "# %s" + (xs +> List.map (fun v -> + let domain = domain_of_value v in + let cnt = + try Hashtbl.find hcnt domain + with Not_found -> + let cnt = ref 0 in + Hashtbl.add hcnt domain cnt; + cnt + in + let i = !cnt in + incr cnt; + (* less: size? *) + spf "%s%d:18" domain i + ) +> Common.join " ")) + ); + + !xxs +> List.iter (fun xs -> + let ints = + xs +> List.map (fun v -> + let i = + match v with + | Z i -> i + | _ -> + let domain = domain_of_value v in + let (_, hdomainconv) = List.assoc domain domains_idx in + Hashtbl.find hdomainconv v + in + i + ) + in + pr (ints +> List.map i_to_s +> Common.join " ") + ); + ) + ); + + (* generate extra .tuples *) + let fvals = try List.assoc "F" domains_idx +> fst with Not_found -> [] in + let nvals = try List.assoc "N" domains_idx +> fst with Not_found -> [] in + let (_vvals, vconv) = List.assoc "V" domains_idx in + let arule = "field_to_var" in + + let file = Filename.concat dir (arule ^ ".tuples") in + Common.with_open_outfile file (fun (pr_no_nl, _chan) -> + let pr s = pr_no_nl (s ^ "\n") in + + pr "# F0:18 V0:18"; + + fvals +> List.iter (fun (fld, idx) -> + match fld with + | F s -> + let v = V s in + let idx2 = Hashtbl.find vconv v in + pr (spf "%d %d" idx idx2) + | _ -> + pr2_gen (fld, idx); + raise Impossible + ) + ); + + let arule = "var_to_func" in + + let file = Filename.concat dir (arule ^ ".tuples") in + Common.with_open_outfile file (fun (pr_no_nl, _chan) -> + let pr s = pr_no_nl (s ^ "\n") in + + pr "# V0:18 N0:18"; + + nvals +> List.iter (fun (n, idx) -> + match n with + | N s -> + let v = V s in + let idx2 = Hashtbl.find vconv v in + (* subtle, different order than for field_to_var, idx2 before *) + pr (spf "%d %d" idx2 idx) + | _ -> + pr2_gen (n, idx); + raise Impossible + ) + ); + + + () + + + +let bddbddb_explain_tuples file = + let (d,b,_e) = Common2.dbe_of_filename file in + let dst = Common2.filename_of_dbe (d,b,"explain") in + Common.with_open_outfile dst (fun (pr_no_nl, _chan) -> + let pr s = pr_no_nl (s ^ "\n") in + + let xs = Common.cat file in + (match xs with + | header::xs -> + if header =~ "# \\(.*\\)" + then + let s = Common.matched1 header in + let flds = Common.split "[ \t]" s in + let fld_domains = + flds +> List.map (fun s -> + if s =~ "\\([A-Z]\\)[0-9]?:" + then Common.matched1 s + else failwith (spf "could not find header in %s" file) + ) + in + let fld_translates = + fld_domains +> List.map (fun s -> + let mapfile = Common2.filename_of_dbe (d,s,"map") in + Common.cat mapfile +> Array.of_list + ) + in + + xs +> List.iter (fun s -> + let vs = Common.split "[ \t]" s +> List.map s_to_i in + + let args = + Common2.zip vs fld_translates +> List.map (fun (i, arr) -> + arr.(i) + ) + in + pr (spf "%s(%s)" b (Common.join ", " args)) + ) + + else failwith (spf "could not find header in %s" file) + + | [] -> pr2 (spf "empty file %s" file) + ) + ); + dst diff --git a/h_program-lang/datalog_code.mli b/h_program-lang/datalog_code.mli new file mode 100644 index 0000000..6e99f89 --- /dev/null +++ b/h_program-lang/datalog_code.mli @@ -0,0 +1,42 @@ + +type var = string +type func = string +type fld = string + +type heap = string +type callsite = string + +type fact = + | PointTo of var * heap + + | Assign of var * var + | AssignContent of var * var + | AssignAddress of var * var + + | AssignDeref of var * var + + | AssignLoadField of var * var * fld + | AssignStoreField of var * fld * var + | AssignFieldAddress of var * var * fld + + | AssignArrayElt of var * var + | AssignArrayDeref of var * var + | AssignArrayElementAddress of var * var + + | Parameter of func * int * var + | Return of func * var (* ret_xxx convention *) + | Argument of callsite * int * var + | ReturnValue of callsite * var + | CallDirect of callsite * func + | CallIndirect of callsite * var + +(* for toy datalog *) +val string_of_fact: + fact -> string + +val bddbddb_of_facts: + fact list -> Common.dirname -> unit + +(* from a .tuples to a .explain *) +val bddbddb_explain_tuples: + Common.filename -> Common.filename diff --git a/h_program-lang/entity_code.ml b/h_program-lang/entity_code.ml new file mode 100644 index 0000000..d03bb57 --- /dev/null +++ b/h_program-lang/entity_code.ml @@ -0,0 +1,165 @@ +(* Yoann Padioleau + * + * Copyright (C) 2009, 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * The code in this module used to be in database_code.ml but many stuff + * now have their own view on how to represent a code database + * (database_code.ml but also graph_code.ml, prolog_code.ml, etc) + *) + +(*****************************************************************************) +(* Type *) +(*****************************************************************************) +(* + * Code entities. + * + * See also http://ctags.sourceforge.net/FORMAT and the doc on 'kind' + * note: if you change this, you may want to bump graph_code.version. + * + * coupling: If you add a constructor modify also entity_kind_of_string()! + * coupling: if you add a new kind of entity, then don't forget to modify + * also size_font_multiplier_of_categ in code_map/. + * + * less: could perhaps factorize code with highlight_code.ml? see + * entity_kind_of_highlight_category_def|use + *) +type entity_kind = + | Package + (* when we use the database for completion purpose, then files/dirs + * are also useful "entities" to get completion for. + *) + | Dir + + | Module + | File + + | Function + | Class + | Type + | Constant | Global + | Macro + | Exception + | TopStmts + + (* nested entities *) + | Field + | Method + | ClassConstant + | Constructor (* for ml *) + + (* forward decl *) + | Prototype | GlobalExtern + + (* people often spread the same component in multiple dirs with the same + * name (hmm could be merged now with Package) + *) + | MultiDirs + + | Other of string + + +(* todo: IsInlinedMethod, ... + * todo: IsOverriding, IsOverriden + *) +type property = + (* mostly function properties *) + + (* todo: could also say which argument is dataflow involved in the + * dynamic call if any + *) + | ContainDynamicCall + | ContainReflectionCall + + (* the argument position taken by ref; 0-index based *) + | TakeArgNByRef of int + + | UseGlobal of string + | ContainDeadStatements + + | DeadCode (* the function itself is dead, e.g. never called *) + | CodeCoverage of int list (* e.g. covered lines by unit tests *) + + (* for class *) + | ClassKind of class_kind + + | Privacy of privacy + | Abstract + | Final + | Static + + (* used for the xhp @required fields for now *) + | Required + | Async + + (* todo: git info, e.g. Age, Authors, Age_profile (range) *) + and privacy = Public | Protected | Private + + and class_kind = Struct | Class_ | Interface | Trait | Enum + + +(*****************************************************************************) +(* String of *) +(*****************************************************************************) + +(* todo: should be autogenerated !! *) +let string_of_entity_kind e = + match e with + | Function -> "Function" + | Prototype -> "Prototype" + | GlobalExtern -> "GlobalExtern" + | Class -> "Class" + + | Module -> "Module" + | Package -> "Package" + | Type -> "Type" + | Constant -> "Constant" + | Global -> "Global" + | Macro -> "Macro" + | TopStmts -> "TopStmts" + | Method -> "Method" + | Field -> "Field" + | ClassConstant -> "ClassConstant" + | Other s -> "Other:" ^ s + | File -> "File" + | Dir -> "Dir" + | MultiDirs -> "MultiDirs" + | Exception -> "Exception" + | Constructor -> "Constructor" + +let entity_kind_of_string s = + match s with + | "Function" -> Function + | "Class" -> Class + | "Module" -> Module + | "Type" -> Type + | "Constant" -> Constant + | "Global" -> Global + | "Macro" -> Macro + | "TopStmts" -> TopStmts + | "Method" -> Method + | "Field" -> Field + | "ClassConstant" -> ClassConstant + | "File" -> File + | "Dir" -> Dir + | "MultiDirs" -> MultiDirs + | "Exception" -> Exception + | "Constructor" -> Constructor + | _ when s =~ "Other:\\(.*\\)" -> Other (Common.matched1 s) + + | _ -> failwith ("entity_of_string: bad string = " ^ s) diff --git a/h_program-lang/entity_code.mli b/h_program-lang/entity_code.mli new file mode 100644 index 0000000..9ebdd2c --- /dev/null +++ b/h_program-lang/entity_code.mli @@ -0,0 +1,60 @@ + +type entity_kind = + (* very high level entities *) + | Package | Dir + | Module | File + + (* toplevel entities *) + | Function + | Class (* used also for struct, interfaces, traits, see class_kind below *) + | Type + | Constant + | Global + | Macro + | Exception + | TopStmts + + (* class member entities *) + | Field + | Method + | ClassConstant + (* ocaml variants (not oo ctor, see Method for that *) + | Constructor + + (* misc *) + | Prototype | GlobalExtern + | MultiDirs (* computed on the fly from many Dir by codemap *) + | Other of string + +val string_of_entity_kind: entity_kind -> string +val entity_kind_of_string: string -> entity_kind + +type property = + (* mostly for Function|Method kind, for codemap to highlight! *) + | ContainDynamicCall | ContainReflectionCall + + | TakeArgNByRef of int (* the argument position taken by ref *) + | UseGlobal of string + | ContainDeadStatements + + | DeadCode (* the function itself is dead, e.g. never called *) + | CodeCoverage of int list (* e.g. covered lines by unit tests *) + + (* for class *) + | ClassKind of class_kind + + | Privacy of privacy + | Abstract | Final + | Static + + (* facebook specific: used for the xhp @required fields for now *) + | Required | Async + + and privacy = Public | Protected | Private + and class_kind = + | Struct | Class_ | Interface + | Trait + (* in Scala, Java, and now PHP enums are actually closer to class + * than C enums. + *) + | Enum diff --git a/h_program-lang/errors_code.ml b/h_program-lang/errors_code.ml new file mode 100644 index 0000000..0cc147e --- /dev/null +++ b/h_program-lang/errors_code.ml @@ -0,0 +1,281 @@ +(* Yoann Padioleau + * + * Copyright (C) 2014 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module E = Entity_code +module PI = Parse_info + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Centralize errors report functions (they did the same in c--). + * Mostly a copy paste of error_php.ml + * + * history: + * - was in check_module.ml + * - was generalized for scheck php + * - introduced ranking via int (but mess) + * - introduced simplified ranking using intermediate rank type + * - fully generalize when introduced graph_code_checker.ml + * - added @Scheck annotation + * - added some false positive deadcode detection + * + * todo: + * - priority to errors, so dead code func more important than dead field + * - factorize code with errors_cpp.ml, errors_php.ml, error_php.ml + *) + +(*****************************************************************************) +(* Globals *) +(*****************************************************************************) +(* see g_errors below *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type error = { + typ: error_kind; + loc: Parse_info.token_location; + sev: severity; +} + (* less: Advice | Noisy | Meticulous ? *) + and severity = Fatal | Warning + + and error_kind = + (* entities *) + (* done while building the graph: + * - UndefinedEntity (UseOfUndefined) + * - MultiDefinedEntity (DupeEntity) + *) + (* As done by my PHP global analysis checker. + * Never done by compilers, and unusual for linters to do that. + * + * note: OCaml 4.01 now does that partially by locally checking if + * an entity is unused and not exported (which does not require + * global analysis) + *) + | Deadcode of entity + | UndefinedDefOfDecl of entity + (* really a special case of Deadcode decl *) + | UnusedExport of entity (* tge decl*) * Common.filename (* file of def *) + + (* call sites *) + (* should be done by the compiler (ocaml does): + * - TooManyArguments, NotEnoughArguments + * - WrongKeywordArguments + * - ... + *) + + (* variables *) + (* also done by some compilers (ocaml does): + * - UseOfUndefinedVariable + * - UnusedVariable + *) + | UnusedVariable of string * Scope_code.scope + + (* classes *) + + (* files (include/import) *) + + (* bail-out constructs *) + (* a proper language should not have that *) + + (* lint *) + + (* other *) + + (* todo: should be merged with Graph_code.entity or put in Database_code?*) + and entity = (string * Entity_code.entity_kind) + + +type rank = + (* Too many FPs for now. Not applied even in strict mode. *) + | Never + (* Usually a few FPs or too many of them. Only applied in strict mode. *) + | OnlyStrict + | Less + | Ok + | Important + | ReallyImportant + +(* @xxx to acknowledge or explain false positives *) +type annotation = + | AtScheck of string + +(* to detect false positives (we use the Hashtbl.find_all property) *) +type identifier_index = (string, Parse_info.token_location) Hashtbl.t + +(*****************************************************************************) +(* Pretty printers *) +(*****************************************************************************) + +let string_of_error_kind error_kind = + match error_kind with + | Deadcode (s, kind) -> + spf "dead %s, %s" (Entity_code.string_of_entity_kind kind) s + | UndefinedDefOfDecl (s, kind) -> + spf "no def found for %s (%s)" s (Entity_code.string_of_entity_kind kind) + | UnusedExport ((s, kind), file_def) -> + spf "useless export of %s (%s) (consider forward decl in %s)" + s (Entity_code.string_of_entity_kind kind) file_def + + | UnusedVariable (name, scope) -> + spf "Unused variable %s, scope = %s" name + (Scope_code.string_of_scope scope) + +(* +let loc_of_node root n g = + try + let info = G.nodeinfo n g in + let pos = info.G.pos in + let file = Filename.concat root pos.PI.file in + spf "%s:%d" file pos.PI.line + with Not_found -> "NO LOCATION" +*) + +let string_of_error err = + let pos = err.loc in + spf "%s:%d: %s" pos.PI.file pos.PI.line (string_of_error_kind err.typ) + + +(*****************************************************************************) +(* Main entry points *) +(*****************************************************************************) + +let g_errors = ref [] + +let fatal loc err = + Common.push { loc = loc; typ = err; sev = Fatal } g_errors +let warning loc err = + Common.push { loc = loc; typ = err; sev = Warning } g_errors + +(*****************************************************************************) +(* Ranking *) +(*****************************************************************************) + +let score_of_rank = function + | Never -> 0 + | OnlyStrict -> 1 + | Less -> 2 + | Ok -> 3 + | Important -> 4 + | ReallyImportant -> 5 + +let rank_of_error err = + match err.typ with + | Deadcode (_s, kind) -> + (match kind with + | E.Function -> Ok + (* or enable when use propagate_uses_of_defs_to_decl in graph_code *) + | E.GlobalExtern | E.Prototype -> Less + | _ -> Ok + ) + (* probably defined in assembly code? *) + | UndefinedDefOfDecl _ -> Important + (* we want to simplify interfaces as much as possible! *) + | UnusedExport _ -> ReallyImportant + | UnusedVariable _ -> Less + + +let score_of_error err = + err +> rank_of_error +> score_of_rank + +(*****************************************************************************) +(* False positives *) +(*****************************************************************************) + +let adjust_errors xs = + xs +> Common.exclude (fun err -> + let file = err.loc.PI.file in + + match err.typ with + | Deadcode (s, kind) -> + (match kind with + | E.Dir | E.File -> true + + (* kencc *) + | E.Prototype when s = "SET" || s = "USED" -> true + + (* FP in graph_code_clang for now *) + | E.Type when s =~ "E__anon" -> true + | E.Type when s =~ "U__anon" -> true + | E.Type when s =~ "S__anon" -> true + | E.Type when s =~ "E__" -> true + | E.Type when s =~ "T__" -> true + + (* FP in graph_code_c for now *) + | E.Type when s =~ "U____anon" -> true + + (* TODO: to remove, but too many for now *) + | E.Constructor + | E.Field + -> true + + (* hmm plan9 specific? being unused for one project does not mean + * it's not used by another one. + *) + | _ when file =~ "^include/" -> true + + | _ when file =~ "^EXTERNAL/" -> true + + (* too many FP on dynamic lang like PHP *) + | E.Method -> true + + | _ -> false + ) + + (* kencc *) + | UndefinedDefOfDecl (("SET" | "USED"), _) -> true + + | UndefinedDefOfDecl _ -> + + (* hmm very plan9 specific *) + file =~ "^include/" || + file = "kernel/lib/lib.h" || + file = "kernel/network/ip/ip.h" || + file =~ "kernel/conf/" || + false + + | _ -> false + ) + +(*****************************************************************************) +(* Annotations *) +(*****************************************************************************) + +let annotation_of_line_opt s = + if s =~ ".*@\\([A-Za-z_]+\\):[ ]?\\([^@]*\\)" + then + let (kind, explain) = Common.matched2 s in + Some (match kind with + | "Scheck" -> AtScheck explain + | s -> failwith ("Bad annotation: " ^ s) + ) + else None + +(* The user can override the checks by adding special annotations + * in the code at the same line than the code it related to. + *) +let annotation_at2 loc = + let file = loc.PI.file in + let line = max (loc.PI.line - 1) 1 in + match Common2.cat_excerpts file [line] with + | [s] -> annotation_of_line_opt s + | _ -> failwith (spf "wrong line number %d in %s" line file) + +let annotation_at a = + Common.profile_code "Errors_code.annotation" (fun () -> annotation_at2 a) diff --git a/h_program-lang/errors_code.mli b/h_program-lang/errors_code.mli new file mode 100644 index 0000000..9dd21b0 --- /dev/null +++ b/h_program-lang/errors_code.mli @@ -0,0 +1,55 @@ + +type error = { + typ: error_kind; + loc: Parse_info.token_location; + sev: severity; +} + and severity = Fatal | Warning + + and error_kind = + | Deadcode of entity + | UndefinedDefOfDecl of entity + | UnusedExport of entity * Common.filename + | UnusedVariable of string * Scope_code.scope + + and entity = (string * Entity_code.entity_kind) + + +(* @xxx to acknowledge or explain false positives *) +type annotation = + | AtScheck of string + +(* to detect false positives (we use the Hashtbl.find_all property) *) +type identifier_index = (string, Parse_info.token_location) Hashtbl.t + + +val string_of_error: error -> string +val string_of_error_kind: error_kind -> string + + +val g_errors: error list ref +(* !modify g_errors! *) +val fatal: Parse_info.token_location -> error_kind -> unit +val warning: Parse_info.token_location -> error_kind -> unit + +type rank = + | Never + | OnlyStrict + | Less + | Ok + | Important + | ReallyImportant + +val score_of_rank: + rank -> int +val rank_of_error: + error -> rank +val score_of_error: + error -> int + +val annotation_at: + Parse_info.token_location -> annotation option + +(* have some approximations and Fps in graph_code_checker so filter them *) +val adjust_errors: + error list -> error list diff --git a/h_program-lang/facts.pl b/h_program-lang/facts.pl new file mode 100644 index 0000000..91fa520 --- /dev/null +++ b/h_program-lang/facts.pl @@ -0,0 +1,5 @@ + +extends('B', 'A'). +extends('C', 'B'). + + diff --git a/h_program-lang/highlight_code.ml b/h_program-lang/highlight_code.ml new file mode 100644 index 0000000..745b069 --- /dev/null +++ b/h_program-lang/highlight_code.ml @@ -0,0 +1,740 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010-2014 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module E = Entity_code + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Emacs-like font-lock-mode, or SourceInsight-like display. + * + * This file contains the generic part of a code highlighter + * that is programming language independent. + * See highlight_xxx.ml for the code specific to the 'xxx' + * programming language. + * + * This source code viewer is based on good semantic information, + * not fragile regexps (as in Emacs), or partial parsing + * (as in SourceInsight, probably because they call cpp). + * + * Augmented visual! Augmented intellect! See what can not see, like in + * movies where HUD show invisible things. + * + * history: + * Some code such as the visitor code was using Emacs_mode_xxx + * visitors before, but now we use directly the raw visitor, cos + * emacs_mode_xxx was not a big win as we must colorize + * and so visit and so get hooks for almost every programming constructs. + * + * Moreover there was some duplication, such as for the different + * categories: I had notes in emacs_mode_xxx and also notes in this file + * about those categories like yacfe_imprecision, cpp, etc. So + * better and cleaner to put all related code in the same file. + * + * + * Why better to have such visualisation ? cf via_pram_readbyte example: + * - better see that use global via1, and that global to module + * - better see local macro + * - better see that some func are local too, the via_pram_writebyte + * - better see if local, or parameter + * - better see in comments that important words such as interrupts, + * and disabled, and must + * + * + * SEMI do first like gtk source view + * SEMI do first like emacs + * SEMI do like my pad emacs mode extension + * SEMI do for yacfe specific stuff + * + * less: level of font-lock-mode ? so can colorify a lot the current function + * and less the rest (so maybe avoid some of the bugs of GText ? + * + * Take more ideas from Source Insight ? + * - variable size parens depending on depth of nestedness + * - do same for curly braces ? + * + * TODO estet: I often revisit in very similar way the code, and do + * some matching to know if pointercall, methodcall, to know if + * prototype or decl extern, to know if typedef inside, or structdef + * inside. Could + * perhaps define helpers so not redo each time same things ? + * + * estet?: redundant with - place_code ? - entity_c ? + * + * related work: + * - http://pygments.org/ + *) + +(*****************************************************************************) +(* Types helpers *) +(*****************************************************************************) + +(* will be italic vs non-italic (could be large vs small ? or bolder ? *) +type usedef = + | Use + | Def + +(* colors will be adjusted (degrade de couleurs) (could also do size? *) +type place = + | PlaceLocal + | PlaceSameDir + | PlaceExternal + (* | ReallyExternal | PlaceCloseHeader *) + + (* will be in a lighter color, almost like wheat, so know we don't have + * information on it. Could highlight in Red because it's + * quite similar to an error. + *) + | NoInfoPlace + + +(* will be underlined or strikedthrough *) +type def_arity = + | UniqueDef + | DoubleDef + | MultiDef + | NoDef + +(* will be different colors *) +type use_arity = + | NoUse + | UniqueUse + | SomeUse + | MultiUse + | LotsOfUse + | HugeUse + + +type use_info = place * def_arity * use_arity +type def_info = use_arity +type usedef2 = + | Use2 of use_info + | Def2 of def_info + +(*****************************************************************************) +(* Main type *) +(*****************************************************************************) + +(* coupling: if add constructor, don't forget to add its handling in 2 places + * below, for its color and associated string representation. + * + * If you look at usedef below, you should get all the way C programmer + * can name things: + * - macro, macrovar + * - functions + * - variables (global/param/local) + * - typedefs, structname, enumname, enum, fields + * - labels + * But at the user site, can see only if + * - FunCallOrMacroCall + * - VarOrEnumValOrMacroVar + * - labels + * - field + * - tag (struct, union, enum) + * - typedef + *) + +(* color, foreground or background will be changed *) +type category = + | Comment + + (* pad addons *) + | Null + | Boolean | Number + + | String | Regexp + + (* classic emacs mode *) + | Keyword (* SEMI multi *) + | KeywordConditional + | KeywordLoop + + | KeywordExn + | KeywordObject + | KeywordModule + + | Builtin + | BuiltinCommentColor (* e.g. for "pr", "pr2", "spf". etc *) + | BuiltinBoolean (* e.g. "not" *) + + | Operator (* TODO multi *) + | Punctuation + + (* Functions, macros, globals, types, ... see Entity_code.entity_kind. + * By default global scope (macro can have local + * but not that used), so no need to like for variables and have a + * global/local dichotomy of scope. (But even if functions are globals, + * still can have some global/local dichotomy but at the module level. + *) + | Entity of Entity_code.entity_kind * usedef2 + + (* kind of specific case of Global of Local which we know are really + * really local. Don't really need a def_arity and place here. *) + | Local of usedef + | Parameter of usedef + + (* less: could be Entity Prototype, but there is just def for Prototype *) + | FunctionDecl of def_info + (* hmm does not fit Constructor use_def, because special kind of use *) + | ConstructorMatch of use_info + + (* less: use Entity instead? *) + | StaticMethod of usedef2 + | StructName of usedef + | EnumName of usedef + (* ClassName of place ... *) + + (* special types *) + | TypeVoid | TypeInt + + (* haskell *) + | FunctionEquation + + (* misc *) + | Label of usedef + + (* semantic information *) + + | BadSmell + (* less: TodoComment? *) + + (* could reuse Global (Use2 ...) but the use of refs is not always + * the use of a global. Moreover using a ref in OCaml is really bad + * which is why I want to highlight it specially. + *) + | UseOfRef + + | PointerCall (* a.k.a dynamic call *) + | CallByRef + | ParameterRef + + | IdentUnknown + + + (* module/cpp related *) + | Ifdef + | Include + | IncludeFilePath + | Define + | CppOther + + (* web related *) + | EmbededCode (* e.g. javascript *) + | EmbededUrl (* e.g. xhp *) + | EmbededHtml (* e.g. xhp *) + | EmbededHtmlAttr + | EmbededStyle (* e.g. css *) + | Verbatim (* for latex, noweb, html pre *) + + (* misc *) + | GrammarRule + + (* Ccomment *) + | CommentWordImportantNotion + | CommentWordImportantModal + + (* pad style specific *) + | CommentSection0 + | CommentSection1 + | CommentSection2 + | CommentSection3 + | CommentSection4 + | CommentEstet + | CommentCopyright + | CommentSyncweb + + (* search and match *) + | MatchGlimpse + | MatchSmPL + | MatchParent + + | MatchSmPLPositif + | MatchSmPLNegatif + + + (* basic *) + | BackGround | ForeGround + + (* parsing imprecision *) + | NotParsed | Passed | Expanded | Error + | NoType + + (* well, normal code *) + | Normal + + +type highlighter_preferences = { + mutable show_type_error: bool; + mutable show_local_global: bool; + +} +let default_highlighter_preferences = { + show_type_error = false; + show_local_global = true; +} + + +(*****************************************************************************) +(* Color and font settings *) +(*****************************************************************************) + +(* + * capabilities: (cf also pango.ml) + * - colors, and can provide semantic information by + * * using opposite colors + * * using close colors, + * * using degrade color + * * using tone (darker, brighter) + * * can also use background/foreground + * + * - fontsize + * - bold, italic, slanted, normal + * - underlined/strikedthrough, pango can even do double underlined + * - fontkind, for instance comment could be in a different font + * in addition of different colors ? + * - casse, smallcaps ? (but can confondre avec macro ?) + * - stretch? (condenset) + * + * Recurrent conventions, which would be counter productive to change maybe: + * - string: green + * - keywords: red/orange + * + * Emacs C-mode conventions: + * - entities declarations: light/dark blue + * (dark for param and local, light for func) + * - types: green + * - keywords: orange/dark-orange, this include: + * - control keywords + * - declaration keywords (static/register, but also struct, typedef) + * - cpp builtin keywords + * - labels: cyan + * - entities used: basic + * - comments: grey + * - strings: dark green + * + * pad: + * - punctuation: blue + * - numbers: yellow + * + * semantic variable: + * - global + * - parameter + * - local + * semantic function: + * - local, defined in file + * - global + * - global and multidef + * - global and utilities, so kind of keyword, like my Common.map or + * like kprintf + * semantic types: + * - local/specific + * - globals + * operators: + * - boolean + * - arithmetic + * - bits + * - memory + * + * notions: + * declaration vs use (italic vs non italic, or large vs small) + * type vs values (use color?) + * control vs data (use color?) + * local vs global (bold vs non bold, also can use degarde de couleur) + * module vs program (use font size ?) + * unique vs multi (use underline ? and strikedthrough ?) + * + * more and more distant => darker ? + * less and less unique => bigger ? + * (but both notions of distant and unique are strongly correlated ?) + * + * Normally can leverage indentation and place in file. We know when + * we are not at the toplevel because of the indentation, so can overload + * some colors. + * + * + * + * final: + * (total colors) + * - blanc + * wheat: default (but what remains default??) + * - noir + * gray: comments + * + * + * + * (primary colors) + * - rouge: + * control, conditional vs loop vs jumps, functions + * - bleue: + * variables, values + * - vert: + * types + * - vert-dark: string, chars + * + * + * (secondary colors) + * - jaune (rouge-vert): + * numbers, value + * - magenta (rouge-bleu): + * + * - cyan (vert-bleu): + * + * + * (tertiary colors) + * - orange (rouge-jaune): + * + * - pourpre (rouge-violet) + * + * - rose: + * + * - turquoise: + * + * - marron + * + *) + +let legend_color_codes = " +The big principles for the colors, fonts, and strikes are: + - italic: for definitions, + normal: for uses + - doubleline: double def, + singleline: multi def, + strike: no def, + normal: single def + - big fonts: use of global variables, or function pointer calls + - lighter: distance of definitions (very light means in same file) + + - gray background: not parsed, no type information, or other tool limitations + - red background: expanded code + - other special backgrounds: search results + + - green: types + - purple: fields + - yellow: functions (and macros) + - blue: globals, variables + - pink: constants, macros + + - cyan and big: global, + turquoise and big: remote global, + dark blue: parameters, + blue: locals + - yellow and big: function pointer, + light yellow: local call (in same file), + dark yellow: remote module call (in same dir) + - salmon: many uses, probably a utility function (e.g. printf) + + - red: problem, no definitions +" + + +let info_of_usedef usedef = + match usedef with + | Def -> [`STYLE `ITALIC] + | Use -> [] + +let info_of_def_arity defarity = + match defarity with + | UniqueDef -> [] + | DoubleDef -> [`UNDERLINE `DOUBLE] + | MultiDef -> [`UNDERLINE `SINGLE] + + | NoDef -> [`STRIKETHROUGH true] + +let info_of_place _defplace = + raise Todo + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +(* pad taste *) +let info_of_category = function + + (* `FAMILY "-misc-*-*-*-*-20-*-*-*-*-*-*"*) + (* `FONT "-misc-fixed-bold-r-normal--13-100-100-100-c-70-iso8859-1" *) + + (* background *) + | BackGround -> [`BACKGROUND "DarkSlateGray"] + | ForeGround -> [`FOREGROUND "wheat";] + + | NotParsed -> [`BACKGROUND "grey42" (*"lightgray"*)] + | NoType -> [`BACKGROUND "DimGray"] + | Passed -> [`BACKGROUND "DarkSlateGray4"] + | Expanded -> [`BACKGROUND "red"] + | Error -> [`BACKGROUND "red2"] + + (* a flashy one that hurts the eye :) *) + | BadSmell -> [`FOREGROUND "magenta"] + + | UseOfRef -> [`FOREGROUND "magenta"] + + | PointerCall -> + [`FOREGROUND "firebrick"; + `WEIGHT `BOLD; + `SCALE `XX_LARGE; + ] + + | ParameterRef -> [`FOREGROUND "magenta"] + | CallByRef -> + [`FOREGROUND "orange"; + `WEIGHT `BOLD; + `SCALE `XX_LARGE; + ] + | IdentUnknown -> [`FOREGROUND "red";] + + (* searches, background *) + | MatchGlimpse -> [`BACKGROUND "grey46"] + | MatchSmPL -> [`BACKGROUND "ForestGreen"] + + | MatchParent -> [`BACKGROUND "blue"] + + | MatchSmPLPositif -> [`BACKGROUND "ForestGreen"] + | MatchSmPLNegatif -> [`BACKGROUND "red"] + + + (* foreground *) + | Comment -> [`FOREGROUND "gray";] + + | CommentSection0 -> [`FOREGROUND "coral";] + | CommentSection1 -> [`FOREGROUND "orange";] + | CommentSection2 -> [`FOREGROUND "LimeGreen";] + | CommentSection3 -> [`FOREGROUND "LightBlue3";] + | CommentSection4 -> [`FOREGROUND "gray";] + + | CommentEstet -> [`FOREGROUND "gray";] + | CommentCopyright -> [`FOREGROUND "gray";] + | CommentSyncweb -> [`FOREGROUND "DimGray";] + + + (* entities *) + | Entity (kind, defkind) -> + (match kind, defkind with + + | E.Type, (Def2 _) -> [`FOREGROUND "chartreuse";] + | E.Type, (Use2 _) -> [`FOREGROUND "chartreuse";] + + | E.Constructor, (Def2 _ ) -> [`FOREGROUND "tomato1";] + | E.Constructor, (Use2 _) -> [`FOREGROUND "pink3";] + + | E.Module, (Def2 _) -> [`FOREGROUND "chocolate";] + | E.Module, (Use2 _) -> [`FOREGROUND "DarkSlateGray4";] + + | E.Field, (Def2 _) -> [`FOREGROUND "MediumPurple1"] @ info_of_usedef (Def) + | E.Field, (Use2 _) -> [`FOREGROUND "MediumPurple2"] @ info_of_usedef (Use) + + | E.Exception, (Def2 _) -> [`FOREGROUND "Orchid1"] @ info_of_usedef (Def) + | E.Exception, (Use2 _) -> [`FOREGROUND "Orchid2"] @ info_of_usedef (Use) + + (* defs *) + | E.Function, (Def2 _) -> [`FOREGROUND "gold"; + `WEIGHT `BOLD;`STYLE `ITALIC; `SCALE `MEDIUM; + ] + | E.Macro, (Def2 _) -> [`FOREGROUND "gold"; + `WEIGHT `BOLD;`STYLE `ITALIC; `SCALE `MEDIUM; + ] + | E.Global, (Def2 _) -> [`FOREGROUND "cyan"; + `WEIGHT `BOLD; `STYLE `ITALIC; `SCALE `MEDIUM; + ] + | E.Constant, (Def2 _) -> [`FOREGROUND "pink"; + `WEIGHT `BOLD; `STYLE `ITALIC; `SCALE `MEDIUM; + ] + | E.Method, (Def2 _) -> [`FOREGROUND "gold3"; + `WEIGHT `BOLD; `SCALE `MEDIUM; + ] + | E.Class, (Def2 _) -> [`FOREGROUND "coral"] @ info_of_usedef (Def) + + (* uses *) + | E.Function, (Use2 (defplace,def_arity,use_arity)) -> + (match defplace with + | PlaceLocal -> [`FOREGROUND "gold";] + | PlaceSameDir -> [`FOREGROUND "goldenrod";] + | PlaceExternal -> + (match use_arity with + | MultiUse -> [`FOREGROUND "DarkGoldenrod"] + + | LotsOfUse | HugeUse | SomeUse -> [`FOREGROUND "salmon";] + + | UniqueUse -> [`FOREGROUND "yellow"] + | NoUse -> [`FOREGROUND "IndianRed";] + ) + | NoInfoPlace -> [`FOREGROUND "LightGoldenrod";] + ) @ info_of_def_arity def_arity + + | E.Global, (Use2 (defplace, def_arity, use_arity)) -> + [`SCALE `X_LARGE] @ + (match defplace with + | PlaceLocal -> [`FOREGROUND "cyan";] + | PlaceSameDir -> [`FOREGROUND "turquoise3";] + | PlaceExternal -> + (match use_arity with + | MultiUse -> [`FOREGROUND "turquoise4"] + | LotsOfUse | HugeUse | SomeUse -> [`FOREGROUND "salmon";] + + | UniqueUse -> [`FOREGROUND "yellow"] + | NoUse -> [`FOREGROUND "IndianRed";] + ) + | NoInfoPlace -> [`FOREGROUND "LightCyan";] + + ) @ info_of_def_arity def_arity + + | E.Constant, (Use2 (defplace, def_arity, use_arity)) -> + (match defplace with + | PlaceLocal -> [`FOREGROUND "pink";] + | PlaceSameDir -> [`FOREGROUND "LightPink";] + | PlaceExternal -> + (match use_arity with + | MultiUse -> [`FOREGROUND "PaleVioletRed"] + + | LotsOfUse | HugeUse | SomeUse -> [`FOREGROUND "salmon";] + + | UniqueUse -> [`FOREGROUND "yellow"] + + | NoUse -> [`FOREGROUND "IndianRed";] + ) + | NoInfoPlace -> [`FOREGROUND "pink1";] + + ) @ info_of_def_arity def_arity + + (* copy paste of MacroVarUse for now *) + | E.Macro, (Use2 (defplace, def_arity, use_arity)) -> + (match defplace with + | PlaceLocal -> [`FOREGROUND "pink";] + | PlaceSameDir -> [`FOREGROUND "LightPink";] + | PlaceExternal -> + (match use_arity with + | MultiUse -> [`FOREGROUND "PaleVioletRed"] + + | LotsOfUse | HugeUse | SomeUse -> [`FOREGROUND "salmon";] + + | UniqueUse -> [`FOREGROUND "yellow"] + | NoUse -> [`FOREGROUND "IndianRed";] + ) + | NoInfoPlace -> [`FOREGROUND "pink1";] + + ) @ info_of_def_arity def_arity + + | E.Method, (Use2 _) -> [`FOREGROUND "gold3";] + + | E.Class, (Use2 _) -> [`FOREGROUND "coral"] @ info_of_usedef (Use) + + | _ -> + failwith (spf "info_of_category: missing case for '%s'" + (Entity_code.string_of_entity_kind kind)) + ) + + | FunctionDecl (_) -> [`FOREGROUND "gold2"; + `WEIGHT `BOLD;`STYLE `ITALIC; `SCALE `MEDIUM; + ] + + | Parameter usedef -> [`FOREGROUND "SteelBlue2";] @ info_of_usedef usedef + | Local usedef -> [`FOREGROUND "SkyBlue1";] @ info_of_usedef usedef + + (* | FunCallMultiDef ->[`FOREGROUND "LightGoldenrod";] *) + + | StaticMethod (Def2 _) -> [`FOREGROUND "gold3"; + `WEIGHT `BOLD; `SCALE `MEDIUM; + ] + | StaticMethod (Use2 _) -> [`FOREGROUND "gold3"; + `WEIGHT `BOLD; `SCALE `MEDIUM; + ] + + + | TypeVoid -> [`FOREGROUND "LimeGreen";] + | TypeInt -> [`FOREGROUND "chartreuse";] + + | ConstructorMatch _ -> [`FOREGROUND "pink1";] + | FunctionEquation -> [`FOREGROUND "LightSkyBlue";] + + | StructName usedef -> [`FOREGROUND "YellowGreen"] @ info_of_usedef usedef + | EnumName usedef -> [`FOREGROUND "YellowGreen"] @ info_of_usedef usedef + + + | Ifdef -> [`FOREGROUND "chocolate";] + | Include -> [`FOREGROUND "DarkOrange2";] + | IncludeFilePath -> [`FOREGROUND "SpringGreen3";] + | Define -> [`FOREGROUND "DarkOrange2";] + | CppOther -> [`FOREGROUND "DarkOrange2";] + + + | Keyword -> [`FOREGROUND "orange";] + | Builtin -> [`FOREGROUND "salmon";] + + | BuiltinCommentColor -> [`FOREGROUND "gray";] + | BuiltinBoolean -> [`FOREGROUND "pink";] + + | KeywordConditional -> [`FOREGROUND "DarkOrange";] + | KeywordLoop -> [`FOREGROUND "sienna1";] + + | KeywordExn -> [`FOREGROUND "orchid";] + | KeywordObject -> [`FOREGROUND "aquamarine3";] + | KeywordModule -> [`FOREGROUND "chocolate";] + + | Number -> [`FOREGROUND "yellow3";] + | Boolean -> [`FOREGROUND "pink3";] + | String -> [`FOREGROUND "MediumSeaGreen";] + | Regexp -> [`FOREGROUND "green3";] + | Null -> [`FOREGROUND "cyan3";] + + + | CommentWordImportantNotion -> + [`FOREGROUND "red"; `SCALE `LARGE;`UNDERLINE `SINGLE; ] + | CommentWordImportantModal -> + [`FOREGROUND "green"; `SCALE `LARGE; `UNDERLINE `SINGLE;] + + | Punctuation -> [`FOREGROUND "cyan";] + + | Operator -> [`FOREGROUND "DeepSkyBlue3";] (* could do better ? *) + + | (Label Def) -> [`FOREGROUND "cyan";] + | (Label Use) -> [`FOREGROUND "CornflowerBlue";] + + + (* to be consistent with Archi_code.Ui color *) + | EmbededHtml -> [`FOREGROUND "RosyBrown"] + | EmbededHtmlAttr ->[`FOREGROUND "burlywood3"] + + | EmbededUrl -> + (* yellow-like color, like function, because it's often + * used as a method call in method programming + *) + [`FOREGROUND "DarkGoldenrod2"] + + | EmbededCode -> [`FOREGROUND "yellow3"] + | EmbededStyle -> [`FOREGROUND "peru"] + | Verbatim -> [`FOREGROUND "plum"] + + | GrammarRule -> [`FOREGROUND "plum"] + + | Normal -> [`FOREGROUND "wheat";] + +(*****************************************************************************) +(* Generic helpers *) +(*****************************************************************************) + +let arity_ids ids = + match ids with + | [] -> NoDef + | [_] -> UniqueDef + | [_;_] -> DoubleDef + | _::_::_::_ -> MultiDef + +let rewrap_arity_def2_category arity categ = + match categ with + | Entity (kind, (Def2 _)) -> Entity (kind, (Def2 arity)) + | FunctionDecl _ -> FunctionDecl (arity) + | StaticMethod (Def2 _) -> StaticMethod (Def2 arity) + | _ -> failwith "not a Def2-kind categoriy" diff --git a/h_program-lang/highlight_code.mli b/h_program-lang/highlight_code.mli new file mode 100644 index 0000000..d64bde7 --- /dev/null +++ b/h_program-lang/highlight_code.mli @@ -0,0 +1,107 @@ + +type category = + | Comment + | Null | Boolean | Number | String | Regexp + + | Keyword + | KeywordConditional | KeywordLoop + | KeywordExn | KeywordObject | KeywordModule + | Builtin | BuiltinCommentColor | BuiltinBoolean + | Operator | Punctuation + + | Entity of Entity_code.entity_kind * usedef2 + + | Local of usedef + | Parameter of usedef + + | FunctionDecl of def_info + | ConstructorMatch of use_info + + | StaticMethod of usedef2 + + | StructName of usedef + | EnumName of usedef + + | TypeVoid | TypeInt + + | FunctionEquation + | Label of usedef + + (* semantic visual feedback! highlight more! *) + | BadSmell + | UseOfRef + | PointerCall + | CallByRef + | ParameterRef + | IdentUnknown + + | Ifdef | Include | IncludeFilePath | Define | CppOther + + | EmbededCode (* e.g. javascript *) + | EmbededUrl (* e.g. xhp *) + | EmbededHtml (* e.g. xhp *) | EmbededHtmlAttr + | EmbededStyle (* e.g. css *) + | Verbatim (* for latex, noweb, html pre *) + + | GrammarRule + + | CommentWordImportantNotion | CommentWordImportantModal + | CommentSection0 | CommentSection1 | CommentSection2 + | CommentSection3 | CommentSection4 + | CommentEstet | CommentCopyright | CommentSyncweb + + | MatchGlimpse | MatchSmPL + | MatchParent + | MatchSmPLPositif | MatchSmPLNegatif + + | BackGround | ForeGround + + (* tools limitations *) + | NotParsed | Passed | Expanded | Error + | NoType + + | Normal + +and usedef = Use | Def + +and usedef2 = Use2 of use_info | Def2 of def_info + + (* semantic visual feedback! *) + and def_info = use_arity + and use_arity = NoUse | UniqueUse | SomeUse | MultiUse | LotsOfUse | HugeUse + + (* semantic visual feedback! *) + and use_info = place * def_arity * use_arity + and place = PlaceLocal | PlaceSameDir | PlaceExternal | NoInfoPlace + and def_arity = UniqueDef | DoubleDef | MultiDef | NoDef + +type highlighter_preferences = { + mutable show_type_error : bool; + mutable show_local_global : bool; +} +val default_highlighter_preferences: highlighter_preferences +val legend_color_codes : string + +(* main entry point *) +val info_of_category : + category -> + [> `BACKGROUND of string + | `FOREGROUND of string + | `SCALE of [> `LARGE | `MEDIUM | `XX_LARGE | `X_LARGE ] + | `STRIKETHROUGH of bool + | `STYLE of [> `ITALIC ] + | `UNDERLINE of [> `DOUBLE | `SINGLE ] + | `WEIGHT of [> `BOLD ] ] + list +(* use the same polymorphic variants than in ocamlgtk *) +val info_of_usedef : + usedef -> + [> `STYLE of [> `ITALIC ] ] list +val info_of_def_arity : + def_arity -> + [> `STRIKETHROUGH of bool | `UNDERLINE of [> `DOUBLE | `SINGLE ] ] list +val info_of_place : 'a -> 'b + +val arity_ids : 'a list -> def_arity +val rewrap_arity_def2_category: def_info -> category -> category + diff --git a/h_program-lang/info_code.ml b/h_program-lang/info_code.ml new file mode 100644 index 0000000..1f44d4d --- /dev/null +++ b/h_program-lang/info_code.ml @@ -0,0 +1,59 @@ +(* Yoann Padioleau + * + * Copyright (C) 2012 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * history: + * - was in main_codestat.ml + * + * Example of project information: + * - http://www.gnu.org/manual/blurbs.html + *) + + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type info_txt = Outline.outline + (* old: (string * string list) list *) + +(*****************************************************************************) +(* IO *) +(*****************************************************************************) + +let load file = + Outline.parse_outline file + +(* old: + let xs = + Common.cat file + +> List.map (Str.global_replace (Str.regexp "#.*") "" ) + +> List.map (Str.global_replace (Str.regexp "\\*+ -----.*") "" ) + +> Common.exclude Common.is_blank_string + in + let xxs = Common.split_list_regexp "^\\*+ " xs in + xxs +> List.map (fun (s, body) -> + if s =~ "^\\*+ \\([^ ]+\\)[ \t]*$" + then + let dir = Common.matched1 s in + dir, body + else + failwith (spf "wrong format in %s, entry: %s" file s) + ) + +*) diff --git a/h_program-lang/info_code.mli b/h_program-lang/info_code.mli new file mode 100644 index 0000000..3d6350b --- /dev/null +++ b/h_program-lang/info_code.mli @@ -0,0 +1,4 @@ + +type info_txt = Outline.outline + +val load: Common.filename -> info_txt diff --git a/h_program-lang/layer_code.ml b/h_program-lang/layer_code.ml new file mode 100644 index 0000000..4c4d073 --- /dev/null +++ b/h_program-lang/layer_code.ml @@ -0,0 +1,796 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * The goal of this module is to provide a data-structure to represent + * code "layers" (a.k.a. code "aspects"). The idea is to imitate google + * earth layers (e.g. the wikipedia layer, panoramio layer, etc), but + * for code. One can have a deadcode layer, a test coverage layer, + * and then can display those layers or not on an existing codebase in + * codemap. The layer is basically some mapping from files to a + * set of lines with a specific color code. + * + * + * A few design choices: + * + * - one could store such information directly into database_xxx.ml + * and have pfff_db compute such information (for instance each function + * could have a set of properties like unit_test, or dead) but this + * would force people to build their own db to visualize the results. + * One could compute this information in database_light_xxx.ml, but this + * will augment the size of the light db slowing down the codemap launch + * even when the people don't use the layers. So it's more flexible to just + * separate layer_code.ml from database_code.ml and have multiple persistent + * files for each information. Also it's quite convenient to have + * utilities like sgrep to be easily extendable to transform a query result + * into a layer. + * + * - How to represent a layer at the macro and micro level in codemap ? + * + * At the micro-level one has just to display the line with the + * requested color. At the macro-level have to either do a majority + * scheme or mixing scheme where for instance draw half of the + * treemap rectangle in red and the other in green. + * + * Because different layers could have different composition needs + * it is simpler to just have the layer say how it should be displayed + * at the macro_level. See the 'macro_level' field below. + * + * - how to have a layer data-structure that can cope with many + * needs ? + * + * Here are some examples of layers and how they are "encoded" by the + * 'layer' type below: + * + * * deadcode (dead function, dead class, dead statement, dead assignnements) + * + * How? dead lines in red color. At the macro_level one can give + * a grey_xxx color with a percentage (e.g. grey53). + * + * * test coverage (static or dynamic) + * + * How? covered lines in green, not covered in red ? Also + * convey a GreyLevel visualization by setting the 'macro_level' field. + * + * * age of file + * + * How? 2010 in green, 2009 in yelow, 2008 in red and so on. + * At the macro_level can do a mix of colors. + * + * * bad smells + * + * How? each bad smell could have a different color and macro_level + * showing a percentage of the rectangle with the right color + * for each smells in the file. + * + * * security patterns (bad smells) + * + * * activity ? + * + * How whow add and delete information ? + * At the micro_level can't show the delete, but at macro_level + * could divide the treemap_rectangle in 2 where percentage of + * add and delete, and also maybe white to show the amount of add + * and delete. Could also use my big circle scheme. + * How link to commit message ? TODO + * + * + * later: + * - could associate more than just a color, e.g. a commit message when want + * to display a version-control layer, or some filling-patterns in + * addition to the color. + * - Could have better precision than the line. + * + * history: + * - I was writing some treemap generator specific for the deadcode + * analysis, the static coverage, the dynamic coverage, and the activity + * in a file (see treemap_php.ml). I was also offering different + * way to visualize the result (DegradeArchiColor | GreyLevel | YesNo). + * It was working fine but there was no easy way to combine 2 + * visualisations, like the age "layer" and the "deadcode" layer + * to see correlations. Also adding simple layers like + * visualizing all calls to HTML() or XHP was requiring to + * write another treemap generator. To be more generic and flexible require + * a real 'layer' type. + *) + +(*****************************************************************************) +(* Type *) +(*****************************************************************************) + +type color = string (* Simple_color.emacs_color *) + +(* note: the filenames must be in readable format so layer files can be reused + * by multiple users. + * + * alternatives: + * - could have line range ? useful for layer matching lots of + * consecutive lines in a file ? + * - todo? have more precision than just the line ? precise pos range ? + * + * - could for the lines instead of a 'kind' to have a 'count', + * and then some mappings from range of values to a color. + * For instance on a coverage layer one could say that from X to Y + * then choose this color, from Y to Z another color. + * But can emulate that by having a "coverage1", "coverage2" + * kind with the current scheme. + * + * - have a macro_level_composing_scheme: Majority | Mixed + * that is then interpreted in codemap instead of forcing + * the layer creator to specific how to show the micro_level + * data at the macro_level. + *) + +type layer = { + title: string; + description: string; + files: (filename * file_info) list; + kinds: (kind * color) list; + } + and file_info = { + + micro_level: (int (* line *) * kind) list; + + (* The list can be empty in which case codemap can use + * the micro_level information and show a mix of colors. + * + * The list can have just one element too and have a kind + * different than the one used in the micro_level. For instance + * for the coverage one can have red/green at micro_level + * and grey_xxx at macro_level. + *) + macro_level: (kind * float (* percentage of rectangle *)) list; + } + (* ugly: because of the ugly way Ocaml.json_of_v currently works + * the kind can not start with a uppercase + *) + and kind = string + + (* with tarzan *) + + +(* The filenames in the index are in absolute path format. That way they + * can be used from codemap in hashtbl and compared to the + * current file. + *) +type layers_with_index = { + root: Common.dirname; + layers: (layer * bool (* is active *)) list; + + micro_index: + (filename, (int, color) Hashtbl.t) Hashtbl.t; + macro_index: + (filename, (float * color) list) Hashtbl.t; +} + +(*****************************************************************************) +(* Reusable properties *) +(*****************************************************************************) + +let red_green_properties = [ + "ok", "green"; + "bad", "red"; + "no_info", "white"; +] + +let heat_map_properties = [ + "cover 100%", "red3"; + "cover 90%", "red1"; + "cover 80%", "orange"; + "cover 70%", "yellow"; + "cover 60%", "YellowGreen"; + "cover 50%", "green"; + "cover 40%", "cyan"; + "cover 30%", "cyan3"; + "cover 20%", "DeepSkyBlue1"; + "cover 10%", "blue"; + (* Should we use a dark blue for 0, as it is the case usually with + * heatmaps? The picture can become very blue then. + * Do not use white though because draw_macrolevel use white when nothing + * was found so we want to differentiate such cases + *) + "cover 0%", "blue4"; (* alternative: snow4 *) + + (* when we zoom on a file we just show red/green coverage, no heat color *) + "ok", "green"; + "bad", "red"; + + "base", "azure4"; + "no_info", "white"; +] + +(*****************************************************************************) +(* Multi layers indexing *) +(*****************************************************************************) + +(* Am I reinventing database indexing ? Should use a real database + * to store layer information so one can then just use SQL to + * fastly get all the information relevant to a file and a line ? + * I doubt MySQL can be as fast and light as my JSON + hashtbl indexing. + *) +let build_index_of_layers ~root layers = + let hmicro = Common2.hash_with_default (fun () -> Hashtbl.create 101) in + let hmacro = Common2.hash_with_default (fun () -> []) in + + layers + +> List.filter (fun (_layer, active) -> active) + +> List.iter (fun (layer, _active) -> + let hkind = Common.hash_of_list layer.kinds in + + layer.files +> List.iter (fun (file, finfo) -> + + let file = Filename.concat root file in + + (* todo? v is supposed to be a float representing a percentage of + * the rectangle but below we will add the macro info of multiple + * layers together which mean the float may not represent percentage + * anynore. They still represent a part of the file though. + * The caller would have to first recompute the sum of all those + * floats to recompute the actual multi-layer percentage. + *) + let color_macro_level = + finfo.macro_level +> Common.map_filter (fun (kind, v) -> + (* some sanity checking *) + try Some (v, Hashtbl.find hkind kind) + with Not_found -> + (* I was originally doing a failwith, but it can be convenient + * to be able to filter kinds in codemap by just editing the + * JSON file and removing certain kind definitions + *) + pr2_once (spf "PB: kind %s was not defined" kind); + None + ) + in + hmacro#update file (fun old -> color_macro_level @ old); + + finfo.micro_level +> List.iter (fun (line, kind) -> + try + let color = Hashtbl.find hkind kind in + + hmicro#update file (fun oldh -> + (* We add so the same line could be assigned multiple colors. + * The order of the layer could determine which color should + * have priority. + *) + Hashtbl.add oldh line color; + oldh + ) + with Not_found -> + pr2_once (spf "PB: kind %s was not defined" kind); + ) + ); + ); + { + layers = layers; + root = root; + macro_index = hmacro#to_h; + micro_index = hmicro#to_h; + } + + +(*****************************************************************************) +(* Layers helpers *) +(*****************************************************************************) +let has_active_layers layers = + layers.layers +> List.map snd +> Common2.or_list + +(*****************************************************************************) +(* Meta *) +(*****************************************************************************) + +(* generated by ocamltarzan *) + +let vof_emacs_color s = Ocaml.vof_string s +let vof_filename s = Ocaml.vof_string s + + +let rec + vof_layer { + title = v_title; + description = v_description; + files = v_files; + kinds = v_kinds + } = + let bnds = [] in + let arg = + Ocaml.vof_list + (fun (v1, v2) -> + let v1 = vof_kind v1 + and v2 = vof_emacs_color v2 + in Ocaml.VTuple [ v1; v2 ]) + v_kinds in + let bnd = ("kinds", arg) in + let bnds = bnd :: bnds in + let arg = + Ocaml.vof_list + (fun (v1, v2) -> + let v1 = vof_filename v1 + and v2 = vof_file_info v2 + in Ocaml.VTuple [ v1; v2 ]) + v_files in + let bnd = ("files", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_string v_description in + let bnd = ("description", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_string v_title in + let bnd = ("title", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and + vof_file_info { micro_level = v_micro_level; macro_level = v_macro_level } + = + let bnds = [] in + let arg = + Ocaml.vof_list + (fun (v1, v2) -> + let v1 = vof_kind v1 + and v2 = Ocaml.vof_float v2 + in Ocaml.VTuple [ v1; v2 ]) + v_macro_level in + let bnd = ("macro_level", arg) in + let bnds = bnd :: bnds in + let arg = + Ocaml.vof_list + (fun (v1, v2) -> + let v1 = Ocaml.vof_int v1 + and v2 = vof_kind v2 + in Ocaml.VTuple [ v1; v2 ]) + v_micro_level in + let bnd = ("micro_level", arg) in + let bnds = bnd :: bnds in Ocaml.VDict bnds +and vof_kind v = Ocaml.vof_string v + +(*****************************************************************************) +(* Ocaml.v -> layer *) +(*****************************************************************************) + +let emacs_color_ofv v = Ocaml.string_ofv v +let filename_ofv v = Ocaml.string_ofv v + +let record_check_extra_fields = ref true + +module Ocamlx = struct +open Ocaml +module J = Json_type + +(* +let stag_incorrect_n_args _loc tag _v = + failwith ("stag_incorrect_n_args on: " ^ tag) +*) + +(* +let unexpected_stag loc v = + failwith ("unexpected_stag:") +*) + +(* +let record_only_pairs_expected loc v = + failwith ("record_only_pairs_expected:") +*) + +let record_duplicate_fields _loc _dup_flds _v = + failwith ("record_duplicate_fields:") + +let record_extra_fields _loc _flds _v = + failwith ("record_extra_fields:") + +let record_undefined_elements _loc _v _xs = + failwith ("record_undefined_elements:") + +let record_list_instead_atom _loc _v = + failwith ("record_list_instead_atom:") + +let tuple_of_size_n_expected _loc n v = + failwith (spf "tuple_of_size_n_expected: %d, got %s" n (Common2.dump v)) + +let rec json_of_v v = + match v with + | VString s -> J.String s + | VSum ((s, vs)) ->J.Array ((J.String s)::(List.map json_of_v vs )) + | VTuple xs -> J.Array (xs +> List.map json_of_v) + | VDict xs -> J.Object (xs +> List.map (fun (s, v) -> + s, json_of_v v + )) + | VList xs -> J.Array (xs +> List.map json_of_v) + | VNone -> J.Null + | VSome v -> J.Array [ J.String "Some"; json_of_v v] + | VRef v -> J.Array [ J.String "Ref"; json_of_v v] + | VUnit -> J.Null (* ? *) + | VBool b -> J.Bool b + + (* Note that 'Inf' can be used as a constructor but is also recognized + * by float_of_string as a float (infinity), so when I was implementing + * this code by reverse engineering the generated sexp, it was important + * to guard certain code. + *) + | VFloat f -> J.Float f + | VChar c -> J.String (Common2.string_of_char c) + | VInt i -> J.Int i + | VTODO _v1 -> J.String "VTODO" + | VVar _v1 -> + failwith "json_of_v: VVar not handled" + | VArrow _v1 -> + failwith "json_of_v: VArrow not handled" + +(* + * Assumes the json was generated via 'ocamltarzan -choice json_of', which + * have certain conventions on how to encode variants for instance. + *) +let rec (v_of_json: Json_type.json_type -> v) = fun j -> + match j with + | J.String s -> VString s + | J.Int i -> VInt i + | J.Float f -> VFloat f + | J.Bool b -> VBool b + | J.Null -> raise Todo + + (* Arrays are used for represent constructors or regular list. Have to + * go sligtly deeper to disambiguate. + *) + | J.Array xs -> + (match xs with + (* VERY VERY UGLY. It is legitimate to have for instance tuples + * of strings where the first element is a string that happen to + * look like a constructor. With this ugly code we currently + * not handle that :( + * + * update: in the layer json file, one can have a filename + * like Makefile and we don't want it to be a constructor ... + * so for now I just generate constructors strings like + * __Pass so we know it comes from an ocaml constructor. + *) + | (J.String s)::xs when s =~ "^__\\([A-Z][A-Za-z_]*\\)$" -> + let constructor = Common.matched1 s in + VSum (constructor, List.map v_of_json xs) + | ys -> + VList (ys +> List.map v_of_json) + ) + | J.Object flds -> + VDict (flds +> List.map (fun (s, fld) -> + s, v_of_json fld + )) + +let save_json file json = + let s = Json_out.string_of_json json in + Common.write_file ~file s + +end + +(* I have not yet an ocamltarzan script for the of_json ... but I have one + * for of_v, so have to pass through OCaml.v ... ugly + *) + +let rec layer_ofv__ = + let _loc = "Xxx.layer" + in + function + | (Ocaml.VDict field_sexps as sexp) -> + let title_field = ref None and description_field = ref None + and files_field = ref None and kinds_field = ref None + and duplicates = ref [] and extra = ref [] in + let rec iter = + (function + | (field_name, field_sexp) :: tail -> + ((match field_name with + | "title" -> + (match !title_field with + | None -> + let fvalue = Ocaml.string_ofv field_sexp + in title_field := Some fvalue + | Some _ -> duplicates := field_name :: !duplicates) + | "description" -> + (match !description_field with + | None -> + let fvalue = Ocaml.string_ofv field_sexp + in description_field := Some fvalue + | Some _ -> duplicates := field_name :: !duplicates) + | "files" -> + (match !files_field with + | None -> + let fvalue = + Ocaml.list_ofv + (function + | Ocaml.VList ([ v1; v2 ]) -> + let v1 = filename_ofv v1 + and v2 = file_info_ofv v2 + in (v1, v2) + | sexp -> + Ocamlx.tuple_of_size_n_expected _loc 2 sexp) + field_sexp + in files_field := Some fvalue + | Some _ -> duplicates := field_name :: !duplicates) + | "kinds" -> + (match !kinds_field with + | None -> + let fvalue = + Ocaml.list_ofv + (function + | Ocaml.VList ([ v1; v2 ]) -> + let v1 = kind_ofv v1 + and v2 = emacs_color_ofv v2 + in (v1, v2) + | sexp -> + Ocamlx.tuple_of_size_n_expected _loc 2 sexp) + field_sexp + in kinds_field := Some fvalue + | Some _ -> duplicates := field_name :: !duplicates) + | _ -> + if !record_check_extra_fields + then extra := field_name :: !extra + else ()); + iter tail) + | [] -> ()) + in + (iter field_sexps; + if !duplicates <> [] + then Ocamlx.record_duplicate_fields _loc !duplicates sexp + else + if !extra <> [] + then Ocamlx.record_extra_fields _loc !extra sexp + else + (match ((!title_field), (!description_field), (!files_field), + (!kinds_field)) + with + | (Some title_value, Some description_value, + Some files_value, Some kinds_value) -> + { + title = title_value; + description = description_value; + files = files_value; + kinds = kinds_value; + } + | _ -> + Ocamlx.record_undefined_elements _loc sexp + [ ((!title_field = None), "title"); + ((!description_field = None), "description"); + ((!files_field = None), "files"); + ((!kinds_field = None), "kinds") ])) + | sexp -> Ocamlx.record_list_instead_atom _loc sexp + +and layer_ofv sexp = layer_ofv__ sexp +and file_info_ofv__ = + let _loc = "Xxx.file_info" + in + function + | (Ocaml.VDict field_sexps as sexp) -> + let micro_level_field = ref None and macro_level_field = ref None + and duplicates = ref [] and extra = ref [] in + let rec iter = + (function + | (field_name, field_sexp) :: tail -> + ((match field_name with + | "micro_level" -> + (match !micro_level_field with + | None -> + let fvalue = + Ocaml.list_ofv + (function + | Ocaml.VList ([ v1; v2 ]) -> + let v1 = Ocaml.int_ofv v1 + and v2 = kind_ofv v2 + in (v1, v2) + | sexp -> + Ocamlx.tuple_of_size_n_expected _loc 2 sexp) + field_sexp + in micro_level_field := Some fvalue + | Some _ -> duplicates := field_name :: !duplicates) + | "macro_level" -> + (match !macro_level_field with + | None -> + let fvalue = + Ocaml.list_ofv + (function + | Ocaml.VList ([ v1; v2 ]) -> + let v1 = kind_ofv v1 + and v2 = Ocaml.float_ofv v2 + in (v1, v2) + | sexp -> + Ocamlx.tuple_of_size_n_expected _loc 2 sexp) + field_sexp + in macro_level_field := Some fvalue + | Some _ -> duplicates := field_name :: !duplicates) + | _ -> + if !record_check_extra_fields + then extra := field_name :: !extra + else ()); + iter tail) + | [] -> ()) + in + (iter field_sexps; + if !duplicates <> [] + then Ocamlx.record_duplicate_fields _loc !duplicates sexp + else + if !extra <> [] + then Ocamlx.record_extra_fields _loc !extra sexp + else + (match ((!micro_level_field), (!macro_level_field)) with + | (Some micro_level_value, Some macro_level_value) -> + { + micro_level = micro_level_value; + macro_level = macro_level_value; + } + | _ -> + Ocamlx.record_undefined_elements _loc sexp + [ ((!micro_level_field = None), "micro_level"); + ((!macro_level_field = None), "macro_level") ])) + | sexp -> Ocamlx.record_list_instead_atom _loc sexp +and file_info_ofv sexp = file_info_ofv__ sexp +and kind_ofv__ = let _loc = "Xxx.kind" in fun sexp -> Ocaml.string_ofv sexp +and kind_ofv sexp = kind_ofv__ sexp + +(*****************************************************************************) +(* Json *) +(*****************************************************************************) + +let json_of_layer layer = + layer +> vof_layer +> Ocamlx.json_of_v + +let layer_of_json json = + json +> Ocamlx.v_of_json +> layer_ofv + +(*****************************************************************************) +(* Load/Save *) +(*****************************************************************************) + +(* we allow to save in JSON format because it may be useful to let + * the user edit the layer file, for instance to adjust the colors. + *) +let load_layer file = + (* pr2 (spf "loading layer: %s" file); *) + if File_type.is_json_filename file + then Json_in.load_json file +> layer_of_json + else Common2.get_value file + +let save_layer layer file = + if File_type.is_json_filename file + (* layer +> vof_layer +> Ocaml.string_of_v +> Common.write_file ~file *) + then layer +> json_of_layer +> Ocamlx.save_json file + else Common2.write_value layer file + +(*****************************************************************************) +(* Layer builder helper *) +(*****************************************************************************) + +(* Simple layer builder - group by file, by line, by property. + * The layer can also be used to summarize statistics per dirs and + * subdirs and so on. + *) +let simple_layer_of_parse_infos ~root ~title ?(description="") xs kinds = + let ranks_kinds = + kinds +> List.map (fun (k, _color) -> k) + +> Common.index_list_1 +> Common.hash_of_list + in + + (* group by file, group by line, uniq categ *) + let files_and_lines = xs +> List.map (fun (tok, kind) -> + let file = Parse_info.file_of_info tok in + let line = Parse_info.line_of_info tok in + let file' = Common2.relative_to_absolute file in + Common.readable ~root file', (line, kind) + ) + in + + let (group_by_file: (Common.filename * (int * kind) list) list) = + Common.group_assoc_bykey_eff files_and_lines + in + + { + title = title; + description = description; + kinds = kinds; + files = group_by_file +> List.map (fun (file, lines_and_kinds) -> + + let (group_by_line: (int * kind list) list) = + Common.group_assoc_bykey_eff lines_and_kinds + in + let all_kinds_in_file = + group_by_line +> List.map snd +> List.flatten +> Common2.uniq in + + (file, { + micro_level = + group_by_line +> List.map (fun (line, kinds) -> + let kinds = Common2.uniq kinds in + (* many kinds om same line, keep highest prio *) + match kinds with + | [] -> raise Impossible + | [x] -> line, x + | _ -> + let sorted = kinds +> List.map (fun x -> + x, Hashtbl.find ranks_kinds x) +> Common.sort_by_val_lowfirst + in + line, List.hd sorted +> fst + ); + + macro_level = + (* we could give a percentage per kind but right now + * we instead give a priority based on the rank of the kinds + * in the kind list + *) + all_kinds_in_file +> List.map (fun kind -> + (kind, 1. /. (float_of_int (Hashtbl.find ranks_kinds kind))) + ) + }) + ); + } + + +(* old: superseded by Layer_code.layer.files and file_info + * type stat_per_file = + * (string (* a property *), int list (* lines *)) Common.assoc + * + * type stats = + * (Common.filename, stat_per_file) Hashtbl.t + * + * + * old: + * let (print_statistics: stats -> unit) = fun h -> + * let xxs = Common.hash_to_list h in + * pr2_gen (xxs); + * () + * + * let gen_security_layer xs = + * let _root = Common.common_prefix_of_files_or_dirs xs in + * let files = Lib_parsing_php.find_php_files_of_dir_or_files xs in + * + * let h = Hashtbl.create 101 in + * + * files +> Common.index_list_and_total +> List.iter (fun (file, i, total) -> + * pr2 (spf "processing: %s (%d/%d)" file i total); + * let ast = Parse_php.parse_program file in + * let stat_file = stat_of_program ast in + * Hashtbl.add h file stat_file + * ); + * Common.write_value h "/tmp/bigh"; + * print_statistics h + *) + + +(* Generates a layer_red_green and layer_heatmap file. + * Take a list of files with a percentage and possibly micro_level + * information. + *) +(* +let layer_red_green_and_heatmap ~root ~output xs = + raise Todo +*) + +(*****************************************************************************) +(* Layer stat *) +(*****************************************************************************) + +(* todo? could be useful also to show # of files involved instead of + * just the line count. + *) +let stat_of_layer layer = + let h = Common2.hash_with_default (fun () -> 0) in + + layer.kinds +> List.iter (fun (kind, _color) -> + h#add kind 0 + ); + layer.files +> List.iter (fun (_file, finfo) -> + finfo.micro_level +> List.iter (fun (_line, kind) -> + h#update kind (fun old -> old + 1) + ) + ); + h#to_list + + +let filter_layer f layer = + { layer with + files = layer.files +> List.filter (fun (file, _) -> f file); + } diff --git a/h_program-lang/layer_code.mli b/h_program-lang/layer_code.mli new file mode 100644 index 0000000..fc3eefb --- /dev/null +++ b/h_program-lang/layer_code.mli @@ -0,0 +1,63 @@ + +type color = string (* Simple_color.emacs_color *) +(* The filenames in this data structure are in readable format + * so one can use the layer generated by another user on + * his own repository (this also saves some space in the generated + * JSON file). + *) +type layer = { + title: string; + description: string; + files: (Common.filename * file_info) list; + kinds: (kind * color) list; + } + and file_info = { + micro_level: (int (* line *) * kind) list; + macro_level: (kind * float (* percentage of rectangle *)) list; + } + (* ugly: the first letter of the propery cannot be in uppercase because + * of the ugly way Ocaml.json_of_v currently works. + *) + and kind = string + +val red_green_properties: (kind * color) list +val heat_map_properties: (kind * color) list + +(* The filenames are in absolute path format in the index. *) +type layers_with_index = { + root: Common.dirname; + layers: (layer * bool (* is active *)) list; + + micro_index: + (Common.filename, (int, color) Hashtbl.t) Hashtbl.t; + macro_index: + (Common.filename, (float * color) list) Hashtbl.t; +} + +val build_index_of_layers: + root:Common.dirname -> + (layer * bool) list -> + layers_with_index +val has_active_layers: layers_with_index -> bool + +(* save either in a (readable) json format or (fast) marshalled form + * depending on the extension of the filename + *) +val load_layer: Common.filename -> layer +val save_layer: layer -> Common.filename -> unit + +(* helpers *) +val json_of_layer: layer -> Json_type.t +val layer_of_json: Json_type.t -> layer + +val simple_layer_of_parse_infos: + root:Common.dirname -> + title:string -> + ?description:string -> + (Parse_info.info * kind) list -> + (kind * color) list -> + layer + +val stat_of_layer: layer -> (kind * int) list + +val filter_layer: (Common.filename -> bool) -> layer -> layer diff --git a/h_program-lang/layer_coverage.ml b/h_program-lang/layer_coverage.ml new file mode 100644 index 0000000..fdad7f3 --- /dev/null +++ b/h_program-lang/layer_coverage.ml @@ -0,0 +1,127 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Thin layer generator wrapper around the Coverage_tests_php.lines_coverage + * data, which itself is generated by running many unit tests with a + * tracer, xdebug or hphpi-tracer, on. + * + * We generate either a layer with red/green colors or one with + * heat-based colors for finer-grained visualization. + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(*****************************************************************************) +(* Helper *) +(*****************************************************************************) + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +let gen_red_green_layer lines_coverage = + { Layer_code. + title = "Test coverage (red/green)"; + description = "Use information from xdebug"; + files = lines_coverage +> List.map (fun (file, lines_cover) -> + let covered = lines_cover.Coverage_code.covered_sites in + let all = lines_cover.Coverage_code.all_sites in + let not_covered = Common2.minus_set all covered in + let percent = + try + Common2.pourcent_good_bad + (List.length covered) (List.length not_covered) + with Division_by_zero -> 0 + in + file, + { Layer_code. + micro_level = + (covered +> List.map (fun line -> line, "ok")) @ + (not_covered +> List.map (fun line -> line, "bad")) + ; + macro_level = [ + (match percent with + | 0 -> "no_info" + | n when n < 50 -> "bad" + | _ -> "ok" + ), + 1. + ]; + } + ); + kinds = Layer_code.red_green_properties; + } + + +(* mostly a copy paste of gen_red_green_layer *) +let gen_heatmap_layer lines_coverage = + + { Layer_code. + title = "Test coverage (heatmap)"; + description = "Use information from xdebug"; + files = lines_coverage +> List.map (fun (file, lines_cover) -> + let covered = lines_cover.Coverage_code.covered_sites in + let all = lines_cover.Coverage_code.all_sites in + let not_covered = Common2.minus_set all covered in + let percent = + try + Common2.pourcent_good_bad + (List.length covered) (List.length not_covered) + with Division_by_zero -> 0 + in + + file, + { Layer_code. + micro_level = + (covered +> List.map (fun line -> line, "ok")) @ + (not_covered +> List.map (fun line -> line, "bad")) + ; + macro_level = [ + (let percent_round = (percent / 10) * 10 in + spf "cover %d%%" percent_round + ), + 1. + ]; + } + ); + kinds = Layer_code.heat_map_properties; + } + + +(*****************************************************************************) +(* Actions *) +(*****************************************************************************) + +let actions () = [ + "-gen_red_green_coverage_layer", " ", + Common.mk_action_2_arg (fun jsonfile output -> + let cover = Coverage_code.load_lines_coverage jsonfile in + let layer = gen_red_green_layer cover in + Layer_code.save_layer layer output + ); + "-gen_heatmap_coverage_layer", " ", + Common.mk_action_2_arg (fun jsonfile output -> + let cover = Coverage_code.load_lines_coverage jsonfile in + let layer = gen_heatmap_layer cover in + Layer_code.save_layer layer output + ); +] diff --git a/h_program-lang/layer_coverage.mli b/h_program-lang/layer_coverage.mli new file mode 100644 index 0000000..4f37d23 --- /dev/null +++ b/h_program-lang/layer_coverage.mli @@ -0,0 +1,9 @@ + +val gen_red_green_layer: + Coverage_code.lines_coverage -> Layer_code.layer + +val gen_heatmap_layer: + Coverage_code.lines_coverage -> Layer_code.layer + +val actions : unit -> Common.cmdline_actions + diff --git a/h_program-lang/layer_parse_errors.ml b/h_program-lang/layer_parse_errors.ml new file mode 100644 index 0000000..98f338b --- /dev/null +++ b/h_program-lang/layer_parse_errors.ml @@ -0,0 +1,101 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) + +open Common + +open Parse_info + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* todo: do some generic red_green_and_heatmap helpers? so can factorize + * code with layer_coverage.ml + *) + +(*****************************************************************************) +(* Helper *) +(*****************************************************************************) + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +let gen_red_green_layer ~root stats = + let root = Common2.relative_to_absolute root in + + { Layer_code. + title = "Parsing errors (red/green)"; + description = ""; + files = stats +> List.map (fun stat -> + let file = + stat.filename +> Common2.relative_to_absolute +> Common.readable ~root + in + + file, + { Layer_code. + micro_level = []; (* TODO use problematic_lines *) + macro_level = [ + (if stat.bad > 0 + then "bad" + else "ok" + ), 1. + ]; + } + ); + kinds = Layer_code.red_green_properties; + } + +let gen_heatmap_layer ~root stats = + let root = Common2.relative_to_absolute root in + + { Layer_code. + title = "Parsing errors (heatmap)"; + description = "lower is better"; + files = stats +> List.map (fun stat -> + let file = + stat.filename +> Common2.relative_to_absolute +> Common.readable ~root + in + let covered = stat.correct in + let not_covered = stat.bad in + + let percent = + try + Common2.pourcent_good_bad not_covered covered + with Division_by_zero -> 0 + in + + file, + { Layer_code. + micro_level = + stat.problematic_lines +> List.map (fun (_strs, lineno) -> + lineno, "bad" + ); + macro_level = [ + (let percent_round = (percent / 10) * 10 in + spf "cover %d%%" percent_round + ), + 1. + ]; + } + ); + kinds = Layer_code.heat_map_properties; + } + + diff --git a/h_program-lang/layer_parse_errors.mli b/h_program-lang/layer_parse_errors.mli new file mode 100644 index 0000000..2d36965 --- /dev/null +++ b/h_program-lang/layer_parse_errors.mli @@ -0,0 +1,7 @@ + +val gen_red_green_layer: + root:Common.dirname -> Parse_info.parsing_stat list -> Layer_code.layer + +val gen_heatmap_layer: + root:Common.dirname -> Parse_info.parsing_stat list -> Layer_code.layer + diff --git a/h_program-lang/license.txt b/h_program-lang/license.txt new file mode 100644 index 0000000..67b72ca --- /dev/null +++ b/h_program-lang/license.txt @@ -0,0 +1,520 @@ +The Library is distributed under the terms of the GNU Lesser General +Public License version 2.1 (included below). + +As a special exception to the GNU Lesser General Public License, you +may link, statically or dynamically, a "work that uses the Library" +with a publicly distributed version of the Library to produce an +executable file containing portions of the Library, and distribute that +executable file under terms of your choice, without any of the additional +requirements listed in clause 6 of the GNU Lesser General Public License. +By "a publicly distributed version of the Library", we mean either the +unmodified Library as distributed by the authors, or a modified version +of the Library that is distributed under the conditions defined in clause +3 of the GNU Lesser General Public License. This exception does not +however invalidate any other reasons why the executable file might be +covered by the GNU Lesser General Public License. + +--------------------------------------------------------------------------- + + GNU LESSER GENERAL PUBLIC LICENSE + Version 2.1, February 1999 + + Copyright (C) 1991, 1999 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the Lesser GPL. It also counts + as the successor of the GNU Library Public License, version 2, hence + the version number 2.1.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Lesser General Public License, applies to some +specially designated software packages--typically libraries--of the +Free Software Foundation and other authors who decide to use it. You +can use it too, but we suggest you first think carefully about whether +this license or the ordinary General Public License is the better +strategy to use in any particular case, based on the explanations below. + + When we speak of free software, we are referring to freedom of use, +not price. Our General Public Licenses are designed to make sure that +you have the freedom to distribute copies of free software (and charge +for this service if you wish); that you receive source code or can get +it if you want it; that you can change the software and use pieces of +it in new free programs; and that you are informed that you can do +these things. + + To protect your rights, we need to make restrictions that forbid +distributors to deny you these rights or to ask you to surrender these +rights. These restrictions translate to certain responsibilities for +you if you distribute copies of the library or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link other code with the library, you must provide +complete object files to the recipients, so that they can relink them +with the library after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + We protect your rights with a two-step method: (1) we copyright the +library, and (2) we offer you this license, which gives you legal +permission to copy, distribute and/or modify the library. + + To protect each distributor, we want to make it very clear that +there is no warranty for the free library. Also, if the library is +modified by someone else and passed on, the recipients should know +that what they have is not the original version, so that the original +author's reputation will not be affected by problems that might be +introduced by others. + + Finally, software patents pose a constant threat to the existence of +any free program. We wish to make sure that a company cannot +effectively restrict the users of a free program by obtaining a +restrictive license from a patent holder. Therefore, we insist that +any patent license obtained for a version of the library must be +consistent with the full freedom of use specified in this license. + + Most GNU software, including some libraries, is covered by the +ordinary GNU General Public License. This license, the GNU Lesser +General Public License, applies to certain designated libraries, and +is quite different from the ordinary General Public License. We use +this license for certain libraries in order to permit linking those +libraries into non-free programs. + + When a program is linked with a library, whether statically or using +a shared library, the combination of the two is legally speaking a +combined work, a derivative of the original library. The ordinary +General Public License therefore permits such linking only if the +entire combination fits its criteria of freedom. The Lesser General +Public License permits more lax criteria for linking other code with +the library. + + We call this license the "Lesser" General Public License because it +does Less to protect the user's freedom than the ordinary General +Public License. It also provides other free software developers Less +of an advantage over competing non-free programs. These disadvantages +are the reason we use the ordinary General Public License for many +libraries. However, the Lesser license provides advantages in certain +special circumstances. + + For example, on rare occasions, there may be a special need to +encourage the widest possible use of a certain library, so that it becomes +a de-facto standard. To achieve this, non-free programs must be +allowed to use the library. A more frequent case is that a free +library does the same job as widely used non-free libraries. In this +case, there is little to gain by limiting the free library to free +software only, so we use the Lesser General Public License. + + In other cases, permission to use a particular library in non-free +programs enables a greater number of people to use a large body of +free software. For example, permission to use the GNU C Library in +non-free programs enables many more people to use the whole GNU +operating system, as well as its variant, the GNU/Linux operating +system. + + Although the Lesser General Public License is Less protective of the +users' freedom, it does ensure that the user of a program that is +linked with the Library has the freedom and the wherewithal to run +that program using a modified version of the Library. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, whereas the latter must +be combined with the library in order to run. + + GNU LESSER GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library or other +program which contains a notice placed by the copyright holder or +other authorized party saying it may be distributed under the terms of +this Lesser General Public License (also called "this License"). +Each licensee is addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also combine or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (1) uses at run time a + copy of the library already present on the user's computer system, + rather than copying library functions into the executable, and (2) + will operate properly with a modified version of the library, if + the user installs one, as long as the modified version is + interface-compatible with the version that the work was made with. + + c) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + d) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + e) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the materials to be distributed need not include anything that is +normally distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties with +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Lesser General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Lesser General Public + License as published by the Free Software Foundation; either + version 2.1 of the License, or (at your option) any later version. + + This library 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 + Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this library; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +Also add information on how to contact you by electronic and paper mail. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the library, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + library `Frob' (a library for tweaking knobs) written by James Random Hacker. + + , 1 April 1990 + Ty Coon, President of Vice + +That's all there is to it! diff --git a/h_program-lang/meta_ast_generic.ml b/h_program-lang/meta_ast_generic.ml new file mode 100644 index 0000000..d953e50 --- /dev/null +++ b/h_program-lang/meta_ast_generic.ml @@ -0,0 +1,11 @@ + +type precision = { + full_info: bool; + token_info: bool; + type_info: bool; +} +let default_precision = { + full_info = false; + token_info = false; + type_info = false; +} diff --git a/h_program-lang/meta_ast_generic.mli b/h_program-lang/meta_ast_generic.mli new file mode 100644 index 0000000..3b30938 --- /dev/null +++ b/h_program-lang/meta_ast_generic.mli @@ -0,0 +1,7 @@ + +type precision = { + full_info: bool; + token_info: bool; + type_info: bool; +} +val default_precision: precision diff --git a/h_program-lang/overlay_code.ml b/h_program-lang/overlay_code.ml new file mode 100644 index 0000000..6e846bb --- /dev/null +++ b/h_program-lang/overlay_code.ml @@ -0,0 +1,223 @@ +(* Yoann Padioleau + * + * Copyright (C) 2011 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Some code organizations are really bad. But because it's harder + * to convince people to change it, sometimes it's simpler to create + * a parallel organization, an "overlay" using simple symlinks + * that represent a better organization. One can then show + * statistics on those overlayed code organization, adapt layers, + * etc + * + * related: LFS on code. + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) +type overlay = { + (* the filenames are in a readable path format *) + orig_to_overlay: (Common.filename, Common.filename) Hashtbl.t; + overlay_to_orig: (Common.filename, Common.filename) Hashtbl.t; + data: (Common.filename (* overlay *) * Common.filename) list; + + (* in realpath format. This information is then specific + * to one user ... but infering back the root_orig/root_overlay + * from an arbitrary directory can be tedious. + *) + root_orig: Common.dirname; + root_overlay: Common.dirname; +} + +(*****************************************************************************) +(* IO *) +(*****************************************************************************) + +let load_overlay file = + Common2.get_value file + +let save_overlay overlay file = + Common2.write_value overlay file + +(*****************************************************************************) +(* Check consistency *) +(*****************************************************************************) + +let check_overlay ~dir_orig ~dir_overlay = + let dir_orig = Common.fullpath dir_orig in + let files = + Common.files_of_dir_or_files_no_vcs_nofilter [dir_orig] + +> Common.exclude (fun file -> file =~ ".*/OVERLAY/.*") + in + + let dir_overlay = Common.fullpath dir_overlay in + let links = + Common.cmd_to_list (spf "find %s -type l" dir_overlay) in + + let links = links +> Common.map_filter (fun file -> + try Some (Common.fullpath file) + with Failure s -> + pr2 s; + None + ) + in + let files2 = + links +> List.map (fun file_or_dir -> + Common.files_of_dir_or_files_no_vcs_nofilter [file_or_dir] + ) +> List.flatten + in + pr2 (spf "#files orig = %d, #links overlay = %d, #files overlay = %d" + (List.length files) (List.length links) (List.length files2) + ); + let h = Hashtbl.create 101 in + files2 +> List.iter (fun file -> + if Hashtbl.mem h file + then pr2 (spf "this one is a dupe: %s" file); + Hashtbl.add h file true; + ); + + let (_common, only_in_orig, only_in_overlay) = + Common2.diff_set_eff files files2 in + + + only_in_orig +> List.iter (fun l -> + pr2 (spf "this one is missing: %s" l); + ); + only_in_overlay +> List.iter (fun l -> + pr2 (spf "this one is gone now: %s" l); + ); + if not (null only_in_orig && null only_in_overlay) + then failwith "Overlay is not OK" + else pr2 "Overlay is OK" + +(*****************************************************************************) +(* Generate equivalences *) +(*****************************************************************************) + +let overlay_equivalences ~dir_orig ~dir_overlay = + let dir_overlay = Common.fullpath dir_overlay in + let dir_orig = Common.fullpath dir_orig in + + let links = + Common.cmd_to_list (spf "find %s -type l" dir_overlay) in + + let equiv = + links +> List.map (fun link -> + let stat = Common2.unix_stat_eff link in + match stat.Unix.st_kind with + | Unix.S_DIR -> + let (children, _) = + Common2.cmd_to_list_and_status (spf + "cd %s; find * -type f" (link)) in + let dir = Common.fullpath link in + + children +> List.map (fun child -> + let overlay = Filename.concat link child in + let orig = Filename.concat dir child in + overlay, orig + ) + | Unix.S_REG -> + [(link, Common.fullpath link)] + | _ -> + [] + ) +> List.flatten + in + let data = + equiv +> Common.map_filter (fun (overlay, orig) -> + try + Some ( + Common.readable ~root:dir_overlay overlay, + Common.readable ~root:dir_orig orig + ) + with exn -> + pr2 (spf "PB with %s, exn = %s" orig (Common.exn_to_s exn)); + None + ) + in + { + data = data; + overlay_to_orig = Common.hash_of_list data; + orig_to_overlay = Common.hash_of_list (data +> List.map Common2.swap); + root_overlay = dir_overlay; + root_orig = dir_orig; + } + +let gen_overlay ~dir_orig ~dir_overlay ~output = + let equiv = overlay_equivalences ~dir_orig ~dir_overlay in + equiv.data +> List.iter pr2_gen; + save_overlay equiv output + +(*****************************************************************************) +(* Adapt layer *) +(*****************************************************************************) + +let adapt_layer layer overlay = + { layer with Layer_code. + files = layer.Layer_code.files +> Common.map_filter (fun (file, info) -> + try + Some (Hashtbl.find overlay.orig_to_overlay file, info) + with Not_found -> + pr2 (spf "PB could not find %s in overlay" file); + None + ); + } + +(* copy paste of the one in main_codemap.ml *) +let layers_in_dir dir = + Common2.readdir_to_file_list dir +> Common.map_filter (fun file -> + if file =~ "layer.*marshall" + then Some (Filename.concat dir file) + else None + ) + +let adapt_layers ~overlay ~dir_layers_orig ~dir_layers_overlay = + let layers = layers_in_dir dir_layers_orig in + + layers +> List.iter (fun layer_filename -> + pr2 (spf "processing %s" layer_filename); + let layer = Layer_code.load_layer layer_filename in + let layer' = adapt_layer layer overlay in + Layer_code.save_layer layer' + (Filename.concat dir_layers_overlay (Common2.basename layer_filename)) + ) + + +(*****************************************************************************) +(* Adapt database code *) +(*****************************************************************************) + +let adapt_database db overlay = + { db with Database_code. + files = db.Database_code.files +> Common.map_filter (fun (file, info) -> + try + Some (Hashtbl.find overlay.orig_to_overlay file, info) + with Not_found -> + pr2 (spf "PB could not find %s in overlay" file); + None + ); + entities = db.Database_code.entities +> Array.map (fun e -> + { e with Database_code. + e_file = + try + (Hashtbl.find overlay.orig_to_overlay e.Database_code.e_file) + with Not_found -> + "not_found_file_overlay"; + } + ); + } diff --git a/h_program-lang/overlay_code.mli b/h_program-lang/overlay_code.mli new file mode 100644 index 0000000..84ab151 --- /dev/null +++ b/h_program-lang/overlay_code.mli @@ -0,0 +1,36 @@ + +type overlay = { + (* the filenames are in a readable path format *) + orig_to_overlay: (Common.filename, Common.filename) Hashtbl.t; + overlay_to_orig: (Common.filename, Common.filename) Hashtbl.t; + data: (Common.filename (* overlay *) * Common.filename) list; + + (* in realpath format *) + root_orig: Common.dirname; + root_overlay: Common.dirname; +} +val overlay_equivalences: + dir_orig:Common.dirname -> dir_overlay:Common.dirname -> + overlay + +val adapt_layer: + Layer_code.layer -> overlay -> Layer_code.layer + +val adapt_database: + Database_code.database -> overlay -> Database_code.database + +val load_overlay: Common.filename -> overlay +val save_overlay: overlay -> Common.filename -> unit + + +val check_overlay: + dir_orig:Common.dirname -> dir_overlay:Common.dirname -> unit + +val gen_overlay: + dir_orig:Common.dirname -> dir_overlay:Common.dirname -> + output:Common.filename -> unit + +val adapt_layers: + overlay:overlay -> + dir_layers_orig:Common.dirname -> dir_layers_overlay:Common.dirname -> + unit diff --git a/h_program-lang/parse_info.ml b/h_program-lang/parse_info.ml new file mode 100644 index 0000000..fc8d39c --- /dev/null +++ b/h_program-lang/parse_info.ml @@ -0,0 +1,992 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Some helpers for the different lexers and parsers in pfff. + * The main types are: + * ('token_location' < 'token_origin' < 'token_mutable') * token_kind + * + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* Currently core/lexing.ml does not handle the line number position. + * Even if there are certain fields in the lexing structure, they are not + * maintained by the lexing engine so the following code does not work: + * + * let pos = Lexing.lexeme_end_p lexbuf in + * sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum + * (pos.pos_cnum - pos.pos_bol) in + * + * Hence those types and functions below to overcome the previous limitation, + * (see especially complete_token_location_large()). + *) +type token_location = { + str: string; + charpos: int; + + line: int; + column: int; + + file: filename; + } + (* with tarzan *) + +let fake_token_location = { + charpos = -1; str = ""; line = -1; column = -1; file = ""; +} + +type token_origin = + (* Present both in the AST and list of tokens *) + | OriginTok of token_location + + (* Present only in the AST and generated after parsing. Can be used + * when building some extra AST elements. *) + | FakeTokStr of string (* to help the generic pretty printer *) * + (* Sometimes we generate fake tokens close to existing + * origin tokens. This can be useful when have to give an error + * message that involves a fakeToken. The int is a kind of + * virtual position, an offset. See compare_pos below. + *) + (token_location * int) option + + (* In the case of a XHP file, we could preprocess it and incorporate + * the tokens of the preprocessed code with the tokens from + * the original file. We want to mark those "expanded" tokens + * with a special tag so that if someone do some transformation on + * those expanded tokens they will get a warning (because we may have + * trouble back-propagating the transformation back to the original file). + *) + | ExpandedTok of + (* refers to the preprocessed file, e.g. /tmp/pp-xxxx.pphp *) + token_location * + (* kind of virtual position. This info refers to the last token + * before a serie of expanded tokens and the int is an offset. + * The goal is to be able to compare the position of tokens + * between then, even for expanded tokens. See compare_pos + * below. + *) + token_location * int + + (* The Ab constructor is (ab)used to call '=' to compare + * big AST portions. Indeed as we keep the token information in the AST, + * if we have an expression in the code like "1+1" and want to test if + * it's equal to another code like "1+1" located elsewhere, then + * the Pervasives.'=' of OCaml will not return true because + * when it recursively goes down to compare the leaf of the AST, that is + * the token_location, there will be some differences of positions. If instead + * all leaves use Ab, then there is no position information and we can + * use '='. See also the 'al_info' function below. + * + * Ab means AbstractLineTok. I Use a short name to not + * polluate in debug mode. + *) + | Ab + + (* with tarzan *) + +type token_mutable = { + (* contains among other things the position of the token through + * the token_location embedded inside the token_origin type. + *) + token : token_origin; + mutable transfo: transformation; + (* less: mutable comments: ...; *) +} + +(* poor's man refactoring *) +and transformation = + | NoTransfo + | Remove + | AddBefore of add + | AddAfter of add + | Replace of add + | AddArgsBefore of string list + + and add = + | AddStr of string + | AddNewlineAndIdent + + (* with tarzan *) + +type token_kind = + (* for the fuzzy parser and sgrep/spatch fuzzy AST *) + | LPar + | RPar + | LBrace + | RBrace + (* for the unparser helpers in spatch, and to filter + * irrelevant tokens in the fuzzy parser + *) + | Esthet of esthet + (* mostly for the lexer helpers, and for fuzzy parser *) + (* less: want to factorize all those TH.is_eof to use that? + * but extra cost? same for TH.is_comment? + * todo: could maybe get rid of that now that we don't really use + * berkeley DB and prefer Prolog, and so we don't need a sentinel + * ast elements to associate the comments with it + *) + | Eof + + | Other + + and esthet = + | Comment + | Newline + | Space + +(* shortcut *) +type info = token_mutable + + +type parsing_stat = { + filename: Common.filename; + mutable correct: int; + mutable bad: int; + (* used only for cpp for now *) + mutable have_timeout: bool; + (* by our cpp commentizer *) + mutable commentized: int; + (* if want to know exactly what was passed through, uncomment: + * + * mutable passing_through_lines: int; + * + * it differs from bad by starting from the error to + * the synchro point instead of starting from start of + * function to end of function. + *) + + (* for instance to report most problematic macros when parse c/c++ *) + mutable problematic_lines: + (string list (* ident in error line *) * int (* line_error *)) list; +} +let default_stat file = { + filename = file; + have_timeout = false; + correct = 0; bad = 0; + commentized = 0; + problematic_lines = []; +} + + +(* Many parsers need to interact with the lexer, or use tricks around + * the stream of tokens, or do some error recovery, or just need to + * pass certain tokens (like the comments token) which requires + * to have access to this stream of remaining tokens. + * The token_state type helps. + *) +type 'tok tokens_state = { + mutable rest: 'tok list; + mutable current: 'tok; + (* it's passed since last "checkpoint", not passed from the beginning *) + mutable passed: 'tok list; + (* if want to do some lalr(k) hacking ... cf yacfe. + * mutable passed_clean : 'tok list; + * mutable rest_clean : 'tok list; + *) +} +let mk_tokens_state toks = { + rest = toks; + current = (List.hd toks); + passed = []; + (* passed_clean = []; + * rest_clean = (toks +> List.filter TH.is_not_comment); + *) + } + +(*****************************************************************************) +(* Lexer helpers *) +(*****************************************************************************) + +let lexbuf_to_strpos lexbuf = + (Lexing.lexeme lexbuf, Lexing.lexeme_start lexbuf) + +let tokinfo_str_pos str pos = + { + token = OriginTok { + charpos = pos; + str = str; + + (* info filled in a post-lexing phase, see complete_token_location_large*) + line = -1; + column = -1; + file = ""; + }; + transfo = NoTransfo; + } + +(* +val rewrap_token_location : token_location.token_location -> info -> info +let rewrap_token_location pi ii = + {ii with pinfo = + (match ii.pinfo with + | OriginTok _oldpi -> OriginTok pi + | FakeTokStr _ | Ab | ExpandedTok _ -> + failwith "rewrap_parseinfo: no OriginTok" + ) + } +*) +let token_location_of_info ii = + match ii.token with + | OriginTok pinfo -> pinfo + (* TODO ? dangerous ? *) + | ExpandedTok (pinfo_pp, _pinfo_orig, _offset) -> pinfo_pp + | FakeTokStr (_, (Some (pi, _))) -> pi + + | FakeTokStr (_, None) + | Ab + -> failwith "token_location_of_info: no OriginTok" + +(* for error reporting *) +(* +let string_of_token_location x = + spf "%s at %s:%d:%d" x.str x.file x.line x.column +*) +let string_of_token_location x = + spf "%s:%d:%d" x.file x.line x.column + +let string_of_info x = + string_of_token_location (token_location_of_info x) + +let str_of_info ii = (token_location_of_info ii).str +let file_of_info ii = (token_location_of_info ii).file +let line_of_info ii = (token_location_of_info ii).line +let col_of_info ii = (token_location_of_info ii).column + +(* todo: return a Real | Virt position ? *) +let pos_of_info ii = (token_location_of_info ii).charpos + +let pinfo_of_info ii = ii.token + +let is_origintok ii = + match ii.token with + | OriginTok _ -> true + | _ -> false + +(* +let opos_of_info ii = + PI.get_orig_info (function x -> x.PI.charpos) ii + +val pos_of_tok : Parser_cpp.token -> int +val str_of_tok : Parser_cpp.token -> string +val file_of_tok : Parser_cpp.token -> Common.filename + +let pos_of_tok x = Ast.opos_of_info (info_of_tok x) +let str_of_tok x = Ast.str_of_info (info_of_tok x) +let file_of_tok x = Ast.file_of_info (info_of_tok x) +let pinfo_of_tok x = Ast.pinfo_of_info (info_of_tok x) + +val is_origin : Parser_cpp.token -> bool +val is_expanded : Parser_cpp.token -> bool +val is_fake : Parser_cpp.token -> bool +val is_abstract : Parser_cpp.token -> bool + + +let is_origin x = + match pinfo_of_tok x with Parse_info.OriginTok _ -> true | _ -> false +let is_expanded x = + match pinfo_of_tok x with Parse_info.ExpandedTok _ -> true | _ -> false +let is_fake x = + match pinfo_of_tok x with Parse_info.FakeTokStr _ -> true | _ -> false +let is_abstract x = + match pinfo_of_tok x with Parse_info.Ab -> true | _ -> false +*) + +(* info about the current location *) +(* +let get_pi = function + | OriginTok pi -> pi + | ExpandedTok (_,pi,_) -> pi + | FakeTokStr (_,(Some (pi,_))) -> pi + | FakeTokStr (_,None) -> + failwith "FakeTokStr None" + | Ab -> + failwith "Ab" +*) + +(* original info *) +let get_original_token_location = function + | OriginTok pi -> pi + | ExpandedTok (pi,_, _) -> pi + | FakeTokStr (_,_) -> failwith "no position information" + | Ab -> failwith "Ab" + +(* used by token_helpers *) +(* +let get_info f ii = + match ii.token with + | OriginTok pi -> f pi + | ExpandedTok (_,pi,_) -> f pi + | FakeTokStr (_,Some (pi,_)) -> f pi + | FakeTokStr (_,None) -> + failwith "FakeTokStr None" + | Ab -> + failwith "Ab" +*) +(* +let get_orig_info f ii = + match ii.token with + | OriginTok pi -> f pi + | ExpandedTok (pi,_, _) -> f pi + | FakeTokStr (_,Some (pi,_)) -> f pi + | FakeTokStr (_,None ) -> + failwith "FakeTokStr None" + | Ab -> + failwith "Ab" +*) + +(* not used but used to be useful in coccinelle *) +type posrv = + | Real of token_location + | Virt of + token_location (* last real info before expanded tok *) * + int (* virtual offset *) + +let compare_pos ii1 ii2 = + let get_pos = function + | OriginTok pi -> Real pi +(* todo? I have this for lang_php/ + | FakeTokStr (s, Some (pi_orig, offset)) -> + Virt (pi_orig, offset) +*) + | FakeTokStr _ + | Ab + -> failwith "get_pos: Ab or FakeTok" + | ExpandedTok (_pi_pp, pi_orig, offset) -> + Virt (pi_orig, offset) + in + let pos1 = get_pos (pinfo_of_info ii1) in + let pos2 = get_pos (pinfo_of_info ii2) in + match (pos1,pos2) with + | (Real p1, Real p2) -> + compare p1.charpos p2.charpos + | (Virt (p1,_), Real p2) -> + if (compare p1.charpos p2.charpos) =|= (-1) + then (-1) + else 1 + | (Real p1, Virt (p2,_)) -> + if (compare p1.charpos p2.charpos) =|= 1 + then 1 + else (-1) + | (Virt (p1,o1), Virt (p2,o2)) -> + let poi1 = p1.charpos in + let poi2 = p2.charpos in + match compare poi1 poi2 with + | -1 -> -1 + | 0 -> compare o1 o2 + | 1 -> 1 + | _ -> raise Impossible + + +let min_max_ii_by_pos xs = + match xs with + | [] -> failwith "empty list, max_min_ii_by_pos" + | [x] -> (x, x) + | x::xs -> + let pos_leq p1 p2 = (compare_pos p1 p2) =|= (-1) in + xs +> List.fold_left (fun (minii,maxii) e -> + let maxii' = if pos_leq maxii e then e else maxii in + let minii' = if pos_leq e minii then e else minii in + minii', maxii' + ) (x,x) + + +(* +let mk_info_item2 ~info_of_tok toks = + let buf = Buffer.create 100 in + let s = + (* old: get_slice_file filename (line1, line2) *) + begin + toks +> List.iter (fun tok -> + let info = info_of_tok tok in + match info.token with + | OriginTok _ + | ExpandedTok _ -> + Buffer.add_string buf (str_of_info info) + + (* the virtual semicolon *) + | FakeTokStr _ -> + () + | Ab -> raise Impossible + ); + Buffer.contents buf + end + in + (s, toks) + +let mk_info_item_DEPRECATED ~info_of_tok a = + Common.profile_code "Parsing.mk_info_item" + (fun () -> mk_info_item2 ~info_of_tok a) +*) + + + +(* +I used to have: + type program2 = toplevel2 list + (* the token list contains also the comment-tokens *) + and toplevel2 = Ast_php.toplevel * Parser_php.token list +type program_with_comments = program2 + +and a function below called distribute_info_items_toplevel that +would distribute the list of tokens to each toplevel entity. +This was when I was storing parts of AST in berkeley DB and when +I wanted to get some information about an entity (a function, a class) +I wanted to get the list also of tokens associated with that entity. + +Now I just have + type program_and_tokens = Ast_php.program * Parser_php.token list +because I don't use berkeley DB. I use codegraph and an entity_finder +we just focus on use/def and does not store huge asts on disk. + + +let rec distribute_info_items_toplevel2 xs toks filename = + match xs with + | [] -> raise Impossible + | [Ast_php.FinalDef e] -> + (* assert (null toks) ??? no cos can have whitespace tokens *) + let info_item = toks in + [Ast_php.FinalDef e, info_item] + | ast::xs -> + + (match ast with + | Ast_js.St (Ast_js.Nop None) -> + distribute_info_items_toplevel2 xs toks filename + | _ -> + + + let ii = Lib_parsing_php.ii_of_any (Ast.Toplevel ast) in + (* ugly: I use a fakeInfo for lambda f_name, so I have + * have to filter the abstract info here + *) + let ii = List.filter PI.is_origintok ii in + let (min, max) = PI.min_max_ii_by_pos ii in + + let toks_before_max, toks_after = +(* on very huge file, this function was previously segmentation fault + * in native mode because span was not tail call + *) + Common.profile_code "spanning tokens" (fun () -> + toks +> Common2.span_tail_call (fun tok -> + match PI.compare_pos (TH.info_of_tok tok) max with + | -1 | 0 -> true + | 1 -> false + | _ -> raise Impossible + )) + in + let info_item = toks_before_max in + (ast, info_item)::distribute_info_items_toplevel2 xs toks_after filename + +let distribute_info_items_toplevel a b c = + Common.profile_code "distribute_info_items" (fun () -> + distribute_info_items_toplevel2 a b c + ) + +*) + +let rewrap_str s ii = + {ii with token = + (match ii.token with + | OriginTok pi -> OriginTok { pi with str = s;} + | FakeTokStr (s, info) -> FakeTokStr (s, info) + | Ab -> Ab + | ExpandedTok _ -> + (* ExpandedTok ({ pi with Common.str = s;},vpi) *) + failwith "rewrap_str: ExpandedTok not allowed here" + ) + } + +let tok_add_s s ii = + rewrap_str ((str_of_info ii) ^ s) ii + +(*****************************************************************************) +(* vtoken -> ocaml *) +(*****************************************************************************) +let vof_filename v = Ocaml.vof_string v + +let vof_token_location { + str = v_str; + charpos = v_charpos; + line = v_line; + column = v_column; + file = v_file + } = + let bnds = [] in + let arg = vof_filename v_file in + let bnd = ("file", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_int v_column in + let bnd = ("column", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_int v_line in + let bnd = ("line", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_int v_charpos in + let bnd = ("charpos", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_string v_str in + let bnd = ("str", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds + + +let vof_token_origin = + function + | OriginTok v1 -> + let v1 = vof_token_location v1 in Ocaml.VSum (("OriginTok", [ v1 ])) + | FakeTokStr (v1, opt) -> + let v1 = Ocaml.vof_string v1 in + let opt = Ocaml.vof_option (fun (p1, i) -> + Ocaml.VTuple [vof_token_location p1; Ocaml.vof_int i] + ) opt + in + Ocaml.VSum (("FakeTokStr", [ v1; opt ])) + | Ab -> Ocaml.VSum (("Ab", [])) + | ExpandedTok (v1, v2, v3) -> + let v1 = vof_token_location v1 in + let v2 = vof_token_location v2 in + let v3 = Ocaml.vof_int v3 in + Ocaml.VSum (("ExpandedTok", [ v1; v2; v3 ])) + + +let rec vof_transformation = + function + | NoTransfo -> Ocaml.VSum (("NoTransfo", [])) + | Remove -> Ocaml.VSum (("Remove", [])) + | AddBefore v1 -> let v1 = vof_add v1 in Ocaml.VSum (("AddBefore", [ v1 ])) + | AddAfter v1 -> let v1 = vof_add v1 in Ocaml.VSum (("AddAfter", [ v1 ])) + | Replace v1 -> let v1 = vof_add v1 in Ocaml.VSum (("Replace", [ v1 ])) + | AddArgsBefore v1 -> let v1 = Ocaml.vof_list Ocaml.vof_string v1 in Ocaml.VSum + (("AddArgsBefore", [ v1 ])) + +and vof_add = + function + | AddStr v1 -> + let v1 = Ocaml.vof_string v1 in Ocaml.VSum (("AddStr", [ v1 ])) + | AddNewlineAndIdent -> Ocaml.VSum (("AddNewlineAndIdent", [])) + +let vof_info + { token = v_token; transfo = v_transfo } = + let bnds = [] in + let arg = vof_transformation v_transfo in + let bnd = ("transfo", arg) in + let bnds = bnd :: bnds in + let arg = vof_token_origin v_token in + let bnd = ("token", arg) in + let bnds = bnd :: bnds in + Ocaml.VDict bnds + + +(*****************************************************************************) +(* Error location report *) +(*****************************************************************************) + +(* A changen is a stand-in for a file for the underlying code. We use + * channels in the underlying parsing code as this avoids loading + * potentially very large source files directly into memory before we + * even parse them, but this makes it difficult to parse small chunks of + * code. The changen works around this problem by providing a channel, + * size and source for underlying data. This allows us to wrap a string + * in a channel, or pass a file, depending on our needs. + *) +type changen = unit -> (in_channel * int * Common.filename) + +(* Many functions in parse_php were implemented in terms of files and + * are now adapted to work in terms of changens. However, we wish to + * provide the original API to users. This wraps changen-based functions + * and makes them operate on filenames again. + *) +let file_wrap_changen : (changen -> 'a) -> (Common.filename -> 'a) = fun f -> + (fun file -> + f (fun () -> (open_in file, Common2.filesize file, file))) + + +(* +let full_charpos_to_pos_from_changen changen = + let (chan, chansize, _) = changen () in + + let size = (chansize + 2) in + + let arr = Array.create size (0,0) in + + let charpos = ref 0 in + let line = ref 0 in + + let rec full_charpos_to_pos_aux () = + try + let s = (input_line chan) in + incr line; + + (* '... +1 do' cos input_line dont return the trailing \n *) + for i = 0 to (String.length s - 1) + 1 do + arr.(!charpos + i) <- (!line, i); + done; + charpos := !charpos + String.length s + 1; + full_charpos_to_pos_aux(); + + with End_of_file -> + for i = !charpos to Array.length arr - 1 do + arr.(i) <- (!line, 0); + done; + (); + in + begin + full_charpos_to_pos_aux (); + close_in chan; + arr + end + +let full_charpos_to_pos2 = file_wrap_changen full_charpos_to_pos_from_changen + +let full_charpos_to_pos a = + profile_code "Common.full_charpos_to_pos" (fun () -> full_charpos_to_pos2 a) +*) + +(* +let test_charpos file = + full_charpos_to_pos file +> Common2.dump +> pr2 +*) + +(* +let complete_token_location filename table x = + { x with + file = filename; + line = fst (table.(x.charpos)); + column = snd (table.(x.charpos)); + } +*) + +let full_charpos_to_pos_large_from_changen = fun changen -> + let (chan, chansize, _) = changen () in + + let size = (chansize + 2) in + + (* old: let arr = Array.create size (0,0) in *) + let arr1 = Bigarray.Array1.create + Bigarray.int Bigarray.c_layout size in + let arr2 = Bigarray.Array1.create + Bigarray.int Bigarray.c_layout size in + Bigarray.Array1.fill arr1 0; + Bigarray.Array1.fill arr2 0; + + let charpos = ref 0 in + let line = ref 0 in + + let full_charpos_to_pos_aux () = + try + while true do begin + let s = (input_line chan) in + incr line; + + (* '... +1 do' cos input_line dont return the trailing \n *) + for i = 0 to (String.length s - 1) + 1 do + (* old: arr.(!charpos + i) <- (!line, i); *) + arr1.{!charpos + i} <- (!line); + arr2.{!charpos + i} <- i; + done; + charpos := !charpos + String.length s + 1; + end done + with End_of_file -> + for i = !charpos to (* old: Array.length arr *) + Bigarray.Array1.dim arr1 - 1 do + (* old: arr.(i) <- (!line, 0); *) + arr1.{i} <- !line; + arr2.{i} <- 0; + done; + (); + in + begin + full_charpos_to_pos_aux (); + close_in chan; + (fun i -> arr1.{i}, arr2.{i}) + end + +let full_charpos_to_pos_large2 = + file_wrap_changen full_charpos_to_pos_large_from_changen + +let full_charpos_to_pos_large a = + profile_code "Common.full_charpos_to_pos_large" + (fun () -> full_charpos_to_pos_large2 a) + +let complete_token_location_large filename table x = + { x with + file = filename; + line = fst (table (x.charpos)); + column = snd (table (x.charpos)); + } + +(*---------------------------------------------------------------------------*) +(* return line x col x str_line from a charpos. This function is quite + * expensive so don't use it to get the line x col from every token in + * a file. Instead use full_charpos_to_pos. + *) +let (info_from_charpos2: int -> filename -> (int * int * string)) = + fun charpos filename -> + + (* Currently lexing.ml does not handle the line number position. + * Even if there is some fields in the lexing structure, they are not + * maintained by the lexing engine :( So the following code does not work: + * let pos = Lexing.lexeme_end_p lexbuf in + * sprintf "at file %s, line %d, char %d" pos.pos_fname pos.pos_lnum + * (pos.pos_cnum - pos.pos_bol) in + * Hence this function to overcome the previous limitation. + *) + let chan = open_in filename in + let linen = ref 0 in + let posl = ref 0 in + let rec charpos_to_pos_aux last_valid = + let s = + try Some (input_line chan) + with End_of_file when charpos =|= last_valid -> None in + incr linen; + match s with + Some s -> + let s = s ^ "\n" in + if (!posl + String.length s > charpos) + then begin + close_in chan; + (!linen, charpos - !posl, s) + end + else begin + posl := !posl + String.length s; + charpos_to_pos_aux !posl; + end + | None -> (!linen, charpos - !posl, "\n") + in + let res = charpos_to_pos_aux 0 in + close_in chan; + res + +let info_from_charpos a b = + profile_code "Common.info_from_charpos" (fun () -> info_from_charpos2 a b) + + +(* Decalage is here to handle stuff such as cpp which include file and who + * can make shift. + *) +let (error_messagebis: filename -> (string * int) -> int -> string)= + fun filename (lexeme, lexstart) decalage -> + + let charpos = lexstart + decalage in + let tok = lexeme in + let (line, pos, linecontent) = info_from_charpos charpos filename in + spf "File \"%s\", line %d, column %d, charpos = %d + around = '%s', whole content = %s" + filename line pos charpos tok (Common2.chop linecontent) + +let error_message = fun filename (lexeme, lexstart) -> + try error_messagebis filename (lexeme, lexstart) 0 + with + End_of_file -> + ("PB in Common.error_message, position " ^ i_to_s lexstart ^ + " given out of file:" ^ filename) + +let error_message_token_location = fun info -> + let filename = info.file in + let lexeme = info.str in + let lexstart = info.charpos in + try error_messagebis filename (lexeme, lexstart) 0 + with + End_of_file -> + ("PB in Common.error_message, position " ^ i_to_s lexstart ^ + " given out of file:" ^ filename) + +let error_message_info info = + let pinfo = token_location_of_info info in + error_message_token_location pinfo + + +(* +let error_message_short = fun filename (lexeme, lexstart) -> + try + let charpos = lexstart in + let (line, pos, linecontent) = info_from_charpos charpos filename in + spf "File \"%s\", line %d" filename line + + with End_of_file -> + begin + ("PB in Common.error_message, position " ^ i_to_s lexstart ^ + " given out of file:" ^ filename); + end +*) + +let print_bad line_error (start_line, end_line) filelines = + begin + pr2 ("badcount: " ^ i_to_s (end_line - start_line)); + + for i = start_line to end_line do + let line = filelines.(i) in + + if i =|= line_error + then pr2 ("BAD:!!!!!" ^ " " ^ line) + else pr2 ("bad:" ^ " " ^ line) + done + end + + +(*****************************************************************************) +(* Parsing statistics *) +(*****************************************************************************) + +(* todo: stat per dir ? give in terms of func_or_decl numbers: + * nbfunc_or_decl pbs / nbfunc_or_decl total ?/ + * + * note: cela dit si y'a des fichiers avec des #ifdef dont on connait pas les + * valeurs alors on parsera correctement tout le fichier et pourtant y'aura + * aucune def et donc aucune couverture en fait. + * ==> TODO evaluer les parties non parsé ? + *) + +let print_parsing_stat_list ?(verbose=false)statxs = +(* old: + let total = List.length statxs in + let perfect = + statxs + +> List.filter (function + | {bad = n; _} when n = 0 -> true + | _ -> false) + +> List.length + in + + pr2 "\n\n\n---------------------------------------------------------------"; + pr2 ( + (spf "NB total files = %d; " total) ^ + (spf "perfect = %d; " perfect) ^ + (spf "=========> %d" ((100 * perfect) / total)) ^ "%" + ); + + let good = statxs +> List.fold_left (fun acc {correct = x; _} -> acc+x) 0 in + let bad = statxs +> List.fold_left (fun acc {bad = x; _} -> acc+x) 0 in + + let gf, badf = float_of_int good, float_of_int bad in + pr2 ( + (spf "nb good = %d, nb bad = %d " good bad) ^ + (spf "=========> %f" (100.0 *. (gf /. (gf +. badf))) ^ "%" + ) + ) +*) + let total = (List.length statxs) in + let perfect = + statxs + +> List.filter (function + {have_timeout = false; bad = 0; _} -> true | _ -> false) + +> List.length + in + + if verbose then begin + pr "\n\n\n---------------------------------------------------------------"; + pr "pbs with files:"; + statxs + +> List.filter (function + | {have_timeout = true; _} -> true + | {bad = n; _} when n > 0 -> true + | _ -> false) + +> List.iter (function + {filename = file; have_timeout = timeout; bad = n; _} -> + pr (file ^ " " ^ (if timeout then "TIMEOUT" else i_to_s n)); + ); + + pr "\n\n\n"; + pr "files with lots of tokens passed/commentized:"; + let threshold_passed = 100 in + statxs + +> List.filter (function + | {commentized = n; _} when n > threshold_passed -> true + | _ -> false) + +> List.iter (function + {filename = file; commentized = n; _} -> + pr (file ^ " " ^ (i_to_s n)); + ); + + pr "\n\n\n"; + end; + + let good = statxs +> List.fold_left (fun acc {correct = x; _} -> acc+x) 0 in + let bad = statxs +> List.fold_left (fun acc {bad = x; _} -> acc+x) 0 in + let passed = statxs +> List.fold_left (fun acc {commentized = x; _} -> acc+x) 0 + in + let total_lines = good + bad in + + pr "---------------------------------------------------------------"; + pr ( + (spf "NB total files = %d; " total) ^ + (spf "NB total lines = %d; " total_lines) ^ + (spf "perfect = %d; " perfect) ^ + (spf "pbs = %d; " (statxs +> List.filter (function + {bad = n; _} when n > 0 -> true | _ -> false) + +> List.length)) ^ + (spf "timeout = %d; " (statxs +> List.filter (function + {have_timeout = true; _} -> true | _ -> false) + +> List.length)) ^ + (spf "=========> %d" ((100 * perfect) / total)) ^ "%" + + ); + let gf, badf = float_of_int good, float_of_int bad in + let passedf = float_of_int passed in + pr ( + (spf "nb good = %d, nb passed = %d " good passed) ^ + (spf "=========> %f" (100.0 *. (passedf /. gf)) ^ "%") + ); + pr ( + (spf "nb good = %d, nb bad = %d " good bad) ^ + (spf "=========> %f" (100.0 *. (gf /. (gf +. badf))) ^ "%" + ) + ) + +(*****************************************************************************) +(* Most problematic tokens *) +(*****************************************************************************) + +(* inspired by a comment by a reviewer of my CC'09 paper *) +let lines_around_error_line ~context (file, line) = + let arr = Common2.cat_array file in + + let startl = max 0 (line - context) in + let endl = min (Array.length arr) (line + context) in + let res = ref [] in + + for i = startl to endl -1 do + Common.push arr.(i) res + done; + List.rev !res + +let print_recurring_problematic_tokens xs = + let h = Hashtbl.create 101 in + xs +> List.iter (fun x -> + let file = x.filename in + x.problematic_lines +> List.iter (fun (xs, line_error) -> + xs +> List.iter (fun s -> + Common2.hupdate_default s + (fun (old, example) -> old + 1, example) + (fun() -> 0, (file, line_error)) h; + ))); + Common2.pr2_xxxxxxxxxxxxxxxxx(); + pr2 ("maybe 10 most problematic tokens"); + Common2.pr2_xxxxxxxxxxxxxxxxx(); + Common.hash_to_list h + +> List.sort (fun (_k1,(v1,_)) (_k2,(v2,_)) -> compare v2 v1) + +> Common.take_safe 10 + +> List.iter (fun (k,(i, (file_ex, line_ex))) -> + pr2 (spf "%s: present in %d parsing errors" k i); + pr2 ("example: "); + let lines = lines_around_error_line ~context:2 (file_ex, line_ex) in + lines +> List.iter (fun s -> pr2 (" " ^ s)); + ); + Common2.pr2_xxxxxxxxxxxxxxxxx(); + () diff --git a/h_program-lang/parse_info.mli b/h_program-lang/parse_info.mli new file mode 100644 index 0000000..c537f65 --- /dev/null +++ b/h_program-lang/parse_info.mli @@ -0,0 +1,124 @@ + +(* ('token_location' < 'token_origin' < 'token_mutable') * token_kind *) + +(* to report errors, regular position information *) +type token_location = { + str: string; (* the content of the "token" *) + charpos: int; (* byte position *) + line: int; column: int; + file: Common.filename; +} +(* see also type filepos = { l: int; c: int; } in common.mli *) + +(* to deal with expanded tokens, e.g. preprocessor like cpp for C *) +type token_origin = + | OriginTok of token_location + | FakeTokStr of string * (token_location * int) option (* next to *) + | ExpandedTok of token_location * token_location * int + | Ab (* abstract token, see parse_info.ml comment *) + +(* to allow source to source transformation via token "annotations", + * see the documentation for spatch + *) +type token_mutable = { + token: token_origin; + (* for spatch *) + mutable transfo: transformation; +} + + and transformation = + | NoTransfo + | Remove + | AddBefore of add + | AddAfter of add + | Replace of add + | AddArgsBefore of string list + + and add = + | AddStr of string + | AddNewlineAndIdent + +(* shortcut *) +type info = token_mutable + +(* mostly for the fuzzy AST builder *) +type token_kind = + | LPar | RPar + | LBrace | RBrace + | Esthet of esthet + | Eof + | Other + and esthet = + | Comment + | Newline + | Space + + +val fake_token_location : token_location + +val str_of_info : info -> string +val line_of_info : info -> int +val col_of_info : info -> int +val pos_of_info : info -> int +val file_of_info : info -> Common.filename + +(* small error reporting, for longer reports use error_message above *) +val string_of_info: info -> string +(* meta *) +val vof_info: info -> Ocaml.v + +val is_origintok: info -> bool + +val token_location_of_info: info -> token_location +val get_original_token_location: token_origin -> token_location + +val compare_pos: info -> info -> int +val min_max_ii_by_pos: info list -> info * info + +type parsing_stat = { + filename: Common.filename; + mutable correct: int; + mutable bad: int; + (* used only for cpp for now *) + mutable have_timeout: bool; + mutable commentized: int; + mutable problematic_lines: (string list * int ) list; +} +val default_stat: Common.filename -> parsing_stat +val print_parsing_stat_list: ?verbose:bool -> parsing_stat list -> unit +val print_recurring_problematic_tokens: parsing_stat list -> unit + + +(* lexer helpers *) +type 'tok tokens_state = { + mutable rest: 'tok list; + mutable current: 'tok; + (* it's passed since last "checkpoint", not passed from the beginning *) + mutable passed: 'tok list; +} +val mk_tokens_state: 'tok list -> 'tok tokens_state + +val tokinfo_str_pos: + string -> int -> info +val lexbuf_to_strpos: + Lexing.lexbuf -> string * int +val rewrap_str: string -> info -> info +val tok_add_s: string -> info -> info + +(* f(i) will contain the (line x col) of the i char position *) +val full_charpos_to_pos_large: + Common.filename -> (int -> (int * int)) +(* fill in the line and column field of token_location that were not set + * during lexing because of limitations of ocamllex. *) +val complete_token_location_large : + Common.filename -> (int -> (int * int)) -> token_location -> token_location + +val error_message : Common.filename -> (string * int) -> string +val error_message_info : info -> string +val print_bad: int -> int * int -> string array -> unit + +(* channel, size, source *) +type changen = unit -> (in_channel * int * Common.filename) +(* Create filename-arged functions from changen-type ones *) +val file_wrap_changen : (changen -> 'a) -> (Common.filename -> 'a) +val full_charpos_to_pos_large_from_changen : changen -> (int -> (int * int)) diff --git a/h_program-lang/pleac.ml b/h_program-lang/pleac.ml new file mode 100644 index 0000000..09104ef --- /dev/null +++ b/h_program-lang/pleac.ml @@ -0,0 +1,232 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) + +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(* + * PLEAC, the Programming Language Examples Alike Cookbook, + * is a great resource when learning a new language. This module + * provides some functions to parse pleac data and to generate + * regular code that can then be analyzed and indexed and + * then visualized like any other code. + * + * See http://pleac.sourceforge.net/ + * + * Important files: + * - skeleton.sgml + * - *.data, language implementations + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type code_excerpt = string list +type section = string + +type comment_style = + string (* comment_start *) * string (* comment_end *) + +type sections = (section, code_excerpt) Common.assoc + +type skeleton = + (string (* section1 *) * + ((string (* section2 title *) * section) list)) + list + + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let skip_no_heading xs = + xs +> Common.exclude (fun (s, _) -> s =$= Common2.split_list_regexp_noheading) + + +let mangle_to_generate_filename s = + Str.global_replace (Str.regexp "[- /.,':()]") "_" s + +(*****************************************************************************) +(* Parsing *) +(*****************************************************************************) + +(* ex: (* @@PLEAC@@_1.0 *), or # @@PLEAC@@_1.0 *) +let regexp_section_pleac_data = "\\(.*\\) @@PLEAC@@_\\([0-9\\.]+\\)\\(.*\\)" +let parse_data_file file = + file + +> Common.cat + +> Common2.split_list_regexp regexp_section_pleac_data +> skip_no_heading + +> List.map (fun (s, group) -> + if s =~ regexp_section_pleac_data + then + let (_, section, _) = Common.matched3 s in + section, group + else + failwith ("Pleac.parse_data_file: impossible: " ^ s) + ) + +let detect_comment_style file = + file + +> Common.cat + +> Common2.return_when (fun s -> + if s =~ regexp_section_pleac_data + then + let (s1, _s2, s3) = Common.matched3 s in + Some (s1, s3) + else None + ) + +(* ex: Strings *) +let regexp_skeleton_section1 = "\\(.*\\)" + +(* ex: Short Sleeps *) +let regexp_skeleton_section2 = "\\(.*\\)" + +(* ex: PLEAC:3.9:CAELP *) +let regexp_skeleton_section_number = "PLEAC:\\(.*\\):" + + +(* It's a sgml file so we could parse it using pxp and then visiting it + * but using regexps is probably ok. + *) +let parse_skeleton_file file = + file + +> Common.cat + +> Common2.split_list_regexp regexp_skeleton_section1 +> skip_no_heading + +> List.map (fun (s, group) -> + if s =~ regexp_skeleton_section1 + then + let section1 = Common.matched1 s in + section1, + group + +> Common2.split_list_regexp regexp_skeleton_section2 +> skip_no_heading + +> List.map (fun (s2, group) -> + if s2 =~ regexp_skeleton_section2 + then + let section2 = Common.matched1 s2 in + section2, + group +> Common2.return_when (fun s3 -> + if s3 =~ regexp_skeleton_section_number + then Some (Common.matched1 s3) + else None + ) + else + failwith ("Pleac.parse_data_file: impossible: " ^ s) + ) + else + failwith ("Pleac.parse_data_file: impossible: " ^ s) + ) + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +(* todo? could also split using class with sections and static methods with + * subsections. So could use M-x Pleac_Strings::TAB :) + *) + +type gen_mode = + | OneFilePerSection + | OneDirPerSection + +let gen_source_files + skeleton sections (comment_start, comment_end) + ~gen_mode + ~output_dir + ~ext_file + ~hook_start_section2 + ~hook_line_body + ~hook_end_section2 + = + + if not (Common2.command2_y_or_no("rm -rf " ^ output_dir)) + then failwith "ok we stop"; + + Common.command2("mkdir -p " ^ output_dir); + + let hsections = Common.hash_of_list sections in + + let estet_sect1 = (Common2.repeat "*" 70) +> Common.join "" in + let estet_sect2 = (Common2.repeat "-" 70) +> Common.join "" in + + (match gen_mode with + | OneFilePerSection -> + skeleton +> List.iter (fun (section1, xs) -> + let file = + Filename.concat output_dir + (mangle_to_generate_filename section1) ^ "." ^ ext_file + in + Common.with_open_outfile file (fun (pr_no_nl, _chan) -> + let pr s = pr_no_nl (s ^ "\n") in + + pr (spf "%s %s %s" comment_start estet_sect1 comment_end); + pr (spf "%s %s %s" comment_start section1 comment_end); + pr (spf "%s %s %s" comment_start estet_sect1 comment_end); + xs +> List.iter (fun (section2, secnumber) -> + let code_opt = + try + Some (Hashtbl.find hsections secnumber) + with Not_found -> + pr2 (spf "Section %s was not found in data file" secnumber); + None + in + pr (spf "%s %s %s" comment_start estet_sect2 comment_end); + pr (spf "%s %s %s" comment_start section2 comment_end); + pr (spf "%s %s %s" comment_start estet_sect2 comment_end); + code_opt +> Common.do_option (fun code -> code +> List.iter pr) + ) + ) + ) + | OneDirPerSection -> + skeleton +> List.iter (fun (section1, xs) -> + let dir = + Filename.concat output_dir + (mangle_to_generate_filename section1) in + + Common.command2("mkdir -p " ^ dir); + + xs +> List.iter (fun (section2, secnumber) -> + let file = + Filename.concat dir + (mangle_to_generate_filename section2) ^ "." ^ ext_file in + + let code_opt = + try + Some (Hashtbl.find hsections secnumber) + with Not_found -> + pr2 (spf "Section %s was not found in data file" secnumber); + None + in + code_opt +> Common.do_option (fun code -> + Common.with_open_outfile file (fun (pr_no_nl, _chan) -> + let pr s = pr_no_nl (s ^ "\n") in + pr (spf "%s %s %s" comment_start estet_sect1 comment_end); + pr (spf "%s %s %s" comment_start section2 comment_end); + pr (spf "%s %s %s" comment_start estet_sect1 comment_end); + pr (hook_start_section2 (mangle_to_generate_filename section2)); + code +> List.iter (fun s -> + pr (hook_line_body s) + ); + pr (hook_end_section2 (mangle_to_generate_filename section2)); + ) + ) + ) + ) + ) + diff --git a/h_program-lang/pleac.mli b/h_program-lang/pleac.mli new file mode 100644 index 0000000..ae32fe9 --- /dev/null +++ b/h_program-lang/pleac.mli @@ -0,0 +1,38 @@ + +(* e.g. "10.1" *) +type section = string + +type code_excerpt = string list + +type comment_style = + string (* comment_start *) * string (* comment_end *) + +type skeleton = + (string (* section1 *) * + ((string (* section2 title *) * section) list)) + list + +type sections = (section, code_excerpt) Common.assoc + +val parse_data_file: + Common.filename -> sections + +val parse_skeleton_file: + Common.filename -> skeleton + +val detect_comment_style: + Common.filename -> comment_style + +type gen_mode = + | OneFilePerSection + | OneDirPerSection + +val gen_source_files: + skeleton -> sections -> comment_style -> + gen_mode:gen_mode -> + output_dir:Common.dirname -> + ext_file:string -> + hook_start_section2:(string -> string) -> + hook_line_body:(string -> string) -> + hook_end_section2:(string -> string) -> + unit diff --git a/h_program-lang/pretty_print_code.ml b/h_program-lang/pretty_print_code.ml new file mode 100644 index 0000000..a881d2a --- /dev/null +++ b/h_program-lang/pretty_print_code.ml @@ -0,0 +1,454 @@ +(* Julien Verlaguet, Yoann Padioleau + * + * Copyright (C) 2011 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* julien: this is a copy/paste of the original pp.ml. + * It is slightly modified, and I don't know how much these modifications + * affect xhpizer. I hope to be able to merge these two files back together. + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* we use a backtracking model *) +exception Fail + +type env = { + (* the actual printing hook, sometimes temporarily set to do_nothing() + * when trying something before actually printing it. *) + print: (string -> unit); + + (* stack of margin, push'ed and pop'ed when processing {} *) + mutable margin: int list; + + (* current column *) + mutable cmargin: int; + (* current line *) + mutable line: int; + + (* depth in the tree of try_ *) + mutable level: int; + + (* for the parenthesis automatic insertion *) + mutable priority: int; + + (* pad: ?? *) + mutable last_nl: bool; + mutable emptyl: bool; + mutable failed: bool; + mutable pushed: bool; +} + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let empty o = { + print = o; + margin = [0]; + priority = 0; + cmargin = 0; + level = 0; + pushed = false; + last_nl = false; + emptyl = false; + failed = false; + line = 0; +} + +let debug env f = + let buf = Buffer.create 256 in + let env' = { env with print = (fun s -> Buffer.add_string buf s)} in + (try f env' with _ -> ()); + Printf.printf "Debug %s\n" (Buffer.contents buf) + +let do_nothing _ = () + +(*****************************************************************************) +(* Newlines and spaces *) +(*****************************************************************************) + +let print env x = + (* todo: this is the case right now for comments. + * we should normalize those comments? + * if (String.contains x '\n') + * then failwith (Printf.sprintf "%s contains a newline\n" x); + *) + + env.last_nl <- false; + env.emptyl <- false; + + env.cmargin <- env.cmargin + String.length x; + if env.cmargin >= 80 + then + (* there is nothing to backtrack on, so just print it *) + if env.level = 0 + then begin env.print x; env.failed <- true end + else raise Fail + else env.print x + +let spaces env = + for _i = 1 to List.hd env.margin do + print env " "; + done + +let newline env = + env.pushed <- false; + if env.last_nl + then env.emptyl <- true; + env.last_nl <- true; + env.cmargin <- 0; + env.line <- env.line + 1; + env.print "\n" + +let newline_opt env = + if env.last_nl + then () + else newline env + +let space_or_nl env = + if env.cmargin < 75 + then print env " " + else (newline env; spaces env) + +(*****************************************************************************) +(* Margins *) +(*****************************************************************************) + +let margin_offset = ref 2 + +let push env = + env.pushed <- true; + env.margin <- List.hd env.margin + !margin_offset :: env.margin + +let pop env = + env.margin <- List.tl env.margin + +let nest env f = + push env; + f env; + pop env + +let nest_opt env f = + if env.pushed + then f env + else begin + push env; + f env; + pop env + end + +let nestc env f = + env.margin <- env.cmargin :: env.margin; + f env; + pop env + +let nest_block env f = + print env "{"; + newline env; + nest env f; + spaces env; + print env "}" + +let nest_block_nl env f = + nest_block env f; + newline env + +(*****************************************************************************) +(* Lists *) +(*****************************************************************************) + +let rec simpl_list env f sep = function + | [] -> () + | [x] -> f env x + | x :: rl -> f env x; print env sep; simpl_list env f sep rl + +let rec list_sep env f sep = function + | [] -> () + | [x] -> f env x + | x :: rl -> f env x; sep env; list_sep env f sep rl + +let flat_list env f opar l sep cpar = + print env opar; + list_sep env f (fun env -> print env sep; print env " ") l; + print env cpar + +(* pad: used to take a last_nl parameter, but it was not used *) +let nl_nested_list env f opar l sep cpar = + print env opar; + nest env (fun env -> + newline env; + spaces env; + list_sep env f (fun env -> print env sep; newline env; spaces env) l; + newline env; + ); + if cpar <> "" + then begin + spaces env; + print env cpar + end + +(*****************************************************************************) +(* Backtracking combinators *) +(*****************************************************************************) + +let fail () = raise Fail + +let try_ env f = + f { env with print = do_nothing; level = env.level + 1}; + f env + + +let choice_left env f1 f2 = + try try_ env f1 + with + | Fail when env.level = 0 -> + (try f2 env with Fail -> assert false) + (* otherwise, just let the exception bubble up more *) + + +let choice_right env f1 f2 = + try try_ env f1 + with Fail -> + f2 env + +let try_hard env f = + try + f { env with print = do_nothing; level = 1 }; + f env + with Fail -> + let env' = { env with failed = false; print = do_nothing; level = 0 } in + f env'; + if env'.failed + then raise Fail + else f { env with level = 0 } + +let cut_list env f l = + List.iter ( + fun x -> + choice_right env + (fun env -> f env x) + (fun env -> newline env; spaces env; f env x) + ) l + + +let list env f opar l sep cpar = + let simple = (fun env -> flat_list env f opar l sep cpar) in + let nested = (fun env -> nl_nested_list env f opar l sep cpar) in + choice_right env simple nested + +let list_left env f opar l sep cpar = + let simple = (fun env -> if l <> [] then print env " "; flat_list env f opar l sep cpar) in + let nested = (fun env -> nl_nested_list env f opar l sep cpar) in + choice_left env simple nested + +let nested_arg env f opar l sep cpar = + let rec elt = function + | [] -> assert false + | [x] -> + f env x; + newline env; + | x :: rl -> + f env x; print env sep; newline env; spaces env; + elt rl + in + nestc env ( + fun env -> + print env opar; + nestc env ( + fun _env -> + elt l; + ); + spaces env; + print env cpar; + ) + + +let fun_args env f opar l sep cpar = + let simple = ( + fun env -> + let line = env.line in + flat_list env f opar l sep cpar; + if line <> env.line then fail(); + ) in + let nl_nested = (fun env -> nl_nested_list env f opar l sep cpar) in + choice_right env simple nl_nested + + +let nested_list env f opar l sep cpar last_nl = + env.margin <- env.cmargin :: env.margin; + print env opar; + env.margin <- env.cmargin :: env.margin; + list_sep env f (fun env -> print env sep; newline env; spaces env) l; + if last_nl + then begin + print env sep; + newline env; + pop env; + spaces env; + print env cpar; + end + else begin + print env cpar; + pop env; + end; + pop env + +let fun_params env f l = + let opar = "(" in + let sep = "," in + let cpar = ")" in + let simple = ( + fun env -> + let line = env.line in + flat_list env f opar l sep cpar; + if line <> env.line then fail(); + ) in + let nl_nested = (fun env -> nested_list env f opar l sep cpar true) in + choice_right env simple nl_nested + +(*****************************************************************************) +(* Parenthesis handling *) +(*****************************************************************************) + +let paren prio env f = + let old_prio = env.priority in + env.priority <- prio; + if (prio >= old_prio) || (prio = -1) + then f env + else begin + print env "("; + f env; + print env ")"; + end; + env.priority <- old_prio + +(*****************************************************************************) +(* String helpers *) +(*****************************************************************************) +(* module PpString = struct *) + +let char_is_space = function + | ' ' | '\t' | '\n' | '\r' -> true + | _ -> false + +let is_space s i = char_is_space s.[i] + +let rec is_only_space s i = + if i >= String.length s + then true + else is_space s i && is_only_space s (i+1) + +let strip s = + let c1 = ref 0 in + let c2 = ref (String.length s - 1) in + while is_space s !c1 do + incr c1; + done; + while is_space s !c2 do + decr c2; + done; + let c2 = String.length s - 1 - !c2 in + String.sub s !c1 (String.length s - !c1 - c2) + +let space = function + | ' ' | '\t' -> true + | _ -> false + +let rec find_cut x start i = + if i < 20 + then start + else if space x.[i] + then i + else find_cut x start (i-1) + +let rec string quote sep env x = + choice_left env ( + fun env -> + print env x + ) ( + fun env -> + let size = 80 - env.cmargin - String.length sep - 1 in + let size = find_cut x size size in + let s = String.sub x 0 size in + let rest = String.sub x size (String.length x - size) in + print env s; + print env quote; + print env sep; + newline env; + spaces env; + print env quote; + string quote sep env rest + ) + +let string quote sep env x = + if env.cmargin >= 20 + then begin + print env quote; + print env x; + print env quote + end + else + nestc env ( + fun env -> + print env quote; + string quote sep env x; + print env quote; + ) + +let first_char_escape env s = + if s = "" then 0 else + match s.[0] with + | 'A' .. 'Z' | 'a' .. 'z' | '&' | ' ' | '\n' | '<' | '>' -> 0 + | _c -> + print env "{'"; + let size = ref 1 in + while !size < String.length s && not (char_is_space s.[!size]) do incr size done; + let size = !size in + print env (String.sub s 0 size); + print env "'}"; + if size < String.length s then print env " "; + size + +let print_text env s = + let size = ref (String.length s - 1) in + while !size >= 0 && char_is_space s.[!size] do + decr size; + done; + let size = !size in + let buf = Buffer.create 80 in + let last_is_space = ref true in + nestc env ( + fun env -> + let i = first_char_escape env s in + for i = i to size do + if Common2.is_space s.[i] + then + if !last_is_space + then () + else begin + last_is_space := true; + print env (Buffer.contents buf); + Buffer.clear buf; + space_or_nl env; + end + else (last_is_space := false; Buffer.add_char buf s.[i]) + done; + print env (Buffer.contents buf); + Buffer.clear buf; + ) diff --git a/h_program-lang/prolog_code.ml b/h_program-lang/prolog_code.ml new file mode 100644 index 0000000..b0d9156 --- /dev/null +++ b/h_program-lang/prolog_code.ml @@ -0,0 +1,175 @@ +(* Yoann Padioleau + * + * Copyright (C) 2014 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module E = Entity_code + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * For more information look at h_program-lang/prolog_code.pl + * and its many predicates. + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* mimics prolog_code.pl top comment *) +type fact = + | At of entity * Common.filename (* readable path *) * int (* line *) + | Kind of entity * Entity_code.entity_kind + + | Type of entity * string (* could be more structured ... *) + + | Extends of string * string + | Implements of string * string + | Mixins of string * string + + | Privacy of entity * Entity_code.privacy + + (* direct use of entities, e.g. foo() *) + | Call of entity * entity + | UseData of entity * entity * bool option (* read/write *) + (* indirect uses of entities, e.g. xxx.f = &foo; *) + | Special of entity (* enclosing *) * + entity (* ctx entity, e.g. function/field/global *) * + entity (* the value *) * + string (* field/function *) + + | Misc of string + + (* todo? could use a record with + * namespace: string list; + * enclosing: string option; + * name: string + *) + and entity = + string list (* package/module/namespace/class/struct/type qualifier*) * + string (* name *) + + +(*****************************************************************************) +(* IO *) +(*****************************************************************************) +(* todo: hmm need to escape x no? In OCaml toplevel values can have a quote + * in their name, like foo'', which will not work well with Prolog atoms. + *) + +(* http://pleac.sourceforge.net/pleac_ocaml/strings.html *) +let escape charlist str = + let rx = Str.regexp ("\\([" ^ charlist ^ "]\\)") in + Str.global_replace rx "\\\\\\1" str + +let escape_quote_and_double_quote s = escape "'\"" s + +let string_of_entity (xs, x) = + match xs with + | [] -> spf "'%s'" (escape_quote_and_double_quote x) + | xs -> spf "('%s', '%s')" (Common.join "." xs) + (escape_quote_and_double_quote x) + +(* Quite similar to database_code.string_of_id_kind, but with lowercase + * because of prolog atom convention. See also prolog_code.pl comment + * about kind/2. + *) +let string_of_entity_kind = function + | E.Function -> "function" + | E.Constant -> "constant" + | E.Global -> "global" + | E.Macro -> "macro" + | E.Class -> "class" + | E.Type -> "type" + + | E.Method -> "method" + | E.ClassConstant -> "constant" + | E.Field -> "field" + | E.Constructor -> "constructor" + + | E.TopStmts -> "stmtlist" + | E.Other _ -> "idmisc" + | E.Exception -> "exception" + + | E.Module -> "module" + | E.Package -> "package" + + | E.Prototype -> "prototype" + | E.GlobalExtern -> "global_extern" + + | (E.MultiDirs|E.Dir|E.File) -> + raise Impossible + +let string_of_fact fact = + let s = + match fact with + | Kind (entity, kind) -> + spf "kind(%s, %s)" (string_of_entity entity) + (string_of_entity_kind kind) + | At (entity, file, line) -> + spf "at(%s, '%s', %d)" (string_of_entity entity) file line + | Type (entity, str) -> + spf "type(%s, '%s')" (string_of_entity entity) + (escape_quote_and_double_quote str) + + | Extends (s1, s2) -> + spf "extends('%s', '%s')" s1 s2 + | Mixins (s1, s2) -> + spf "mixins('%s', '%s')" s1 s2 + | Implements (s1, s2) -> + spf "implements('%s', '%s')" s1 s2 + + | Privacy (entity, p) -> + let predicate = + match p with + | E.Public -> "is_public" + | E.Private -> "is_private" + | E.Protected -> "is_protected" + in + spf "%s(%s)" predicate (string_of_entity entity) + + (* less: depending on kind of e1 we could have 'method' or 'constructor'*) + | Call (e1, e2) -> + spf "docall(%s, %s)" + (string_of_entity e1) (string_of_entity e2) + | UseData (e1, e2, b) -> + spf "use(%s, %s, %s)" + (string_of_entity e1) (string_of_entity e2) + (match b with + | None -> "na" + | Some true -> "write" + | Some false -> "read" + ) + | Special (e1, e2, e3, str) -> + spf "special(%s, %s, %s, '%s')" + (string_of_entity e1) + (string_of_entity e2) + (string_of_entity e3) + str + + | Misc s -> s + in + s ^ "." + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let entity_of_str s = + let xs = Common.split "\\." s in + match List.rev xs with + | [] -> raise Impossible + | [x] -> ([], x) + | x::xs -> (List.rev xs, x) diff --git a/h_program-lang/prolog_code.mli b/h_program-lang/prolog_code.mli new file mode 100644 index 0000000..0282dfc --- /dev/null +++ b/h_program-lang/prolog_code.mli @@ -0,0 +1,26 @@ + +type fact = + | At of entity * Common.filename (* readable path *) * int (* line *) + | Kind of entity * Entity_code.entity_kind + | Type of entity * string + + | Extends of string * string + | Implements of string * string + | Mixins of string * string + + | Privacy of entity * Entity_code.privacy + + | Call of entity * entity + | UseData of entity * entity * bool option (* read/write *) + | Special of entity * entity * entity * string (* field/function *) + + | Misc of string + + and entity = + string list (* package/module/namespace/class qualifier*) * string (* name *) + +val string_of_fact: fact -> string +val entity_of_str: string -> entity + +(* reused in other modules which generate prolog facts *) +val string_of_entity_kind: Entity_code.entity_kind -> string diff --git a/h_program-lang/prolog_code.pl b/h_program-lang/prolog_code.pl new file mode 100644 index 0000000..d82515c --- /dev/null +++ b/h_program-lang/prolog_code.pl @@ -0,0 +1,407 @@ +% -*- prolog -*- + +%--------------------------------------------------------------------------- +% Prelude +%--------------------------------------------------------------------------- + +% This file is the basis of an interactive tool a la SQL to query +% information about the structure of a codebase (the inheritance tree, +% the call graph, the data graph), for instance "What are all the +% children of class Foo?". The data is the code. The query language is +% Prolog (http://en.wikipedia.org/wiki/Prolog), a logic-based +% programming language used mainly in AI but also popular in database +% (http://en.wikipedia.org/wiki/Datalog). The particular Prolog +% implementation we use for now is SWI-prolog +% (http://www.swi-prolog.org/pldoc/refman/). We've chosen Prolog over +% SQL because it's really easy to define recursive predicates like +% children/2 (see below) in Prolog, and such predicates are necessary +% when dealing with object-oriented codebase. +% +% This tool is inspired by a similar tool for Java called JQuery +% (http://jquery.cs.ubc.ca/, nothing to do with the JS library), itself +% inspired by CIA (C Information Abstractor). The code below is mostly +% generic (programming language agnostic) but it was tested mainly +% on PHP, Java (and its bytecode), and OCaml code (see +% lang_php/analyze/foundation/unit_prolog_php.ml, +% lang_bytecode/analyze/unit_analyze_bytecode.ml, and +% lang_ml/analyze/unit_analyze_ml.ml). +% +% This file assumes the presence of another file, facts.pl, containing +% the actual "database" of facts about a codebase. There is potentially +% an infinite numbers of predicates we could define. For instance +% does the method contains a for loop, does it call '+', etc. But for now +% we focus on predicates related to entities, to names, e.g. defs and uses +% of functions/classes/etc. +% Here are the predicates that should be defined in facts.pl: +% +% - entities: kind/2 with the +% function/method, constant, class/interface/trait, field +% atoms. +% ex: kind('array_map', function). +% ex: kind('Preparable', class). +% ex: kind(('Preparable', 'gen'), method). +% ex: kind((Preparable', '__count'), field). +% ex: kind((Preparable', 'OK'), constant). +% The identifier for a function is its name in a string and for +% class members a pair with the name of the class and then the member name, +% both in a string. We don't differentiate methods from static methods; +% the static/1 predicate below can be used for that (same for fields). +% Note that for fields the name of the field does not contain the $ because +% when used, as in '$this->field, there is no $. +% +% - callgraph: docall/3, special/1 with the function/method/class atoms +% to differentiate regular function calls, method calls, and class +% instantiations via new (see also the calls/2 infix operator). +% ex: docall('foo', 'bar', function). +% ex: docall(('A', 'foo'), 'toInt', method). +% ex: docall('foo', ':x:frag', class). +% Note that for method calls we actually don't resolve to which class +% the method belongs to (that would require to leverage results from +% an interprocedural static analysis) unless it's a static method call. +% Note that we use 'docall' and not 'call' because call is a +% reserved predicate in Prolog. +% A new atom 'special' can be used to indicate calls to special functions +% taking entities as parameters. For instance a wrapper to 'new' in +% a dynamic language like PHP. +% ex: docall('foo', ('new_wrapper','A'), special). +% and a special/1 predicate is used to remember all those special functions. +% ex: special('new_wrapper'). +% +% +% - exception graph: throw/2, catch/2. +% ex: throw('foo', 'ViolationException'). +% ex: catch('bar', 'Exception'). +% +% - datagraph: use/4 with the field/array atoms to differentiate access +% to object members, and access to fields of an array (often because people +% abuse arrays to represent records), and the read/write atoms to +% indicate in which position the field is used. +% ex: use('foo', 'count', field, read). +% ex: use(('A','foo'), 'name', array, write). +% +% - types: type/2, parameter/4, return/2, arity/2 +% ex: type('foobar', 'int'). +% ex: parameter('foo', 0, '$first_param_name', 'int') +% ex: return('foo', 'int') +% ex: arity('foobar', 3). +% ex: arity(('Preparable', 'gen'), 0). +% +% - properties: static/1, abstract/1, final/1, is_public/1, is_private/1, +% is_protected/1, async/1 +% ex: static(('Filesystem', 'readFile')). +% ex: abstract('AbstractTestCase'). +% ex: is_public(('Preparable', 'gen')). +% We use 'is_public' and not 'public' because public is a reserved keyword +% in Prolog. +% +% - inheritance: extends/2, implements/2, mixins/2 +% ex: extends('EntPhoto', 'Ent'). +% ex: implements('MyTest', 'NeedSqlShim'). +% ex: mixins('MyTest', 'TraitHaveFeedback'). +% See also the children/2, parent/2, related/2, isa/2, inherits/2, +% reuses/2, predicates defined below, where isa and inherits are +% infix operators. +% +% - include/require: include/2, require_module/2 +% ex: include('wap/index.php', 'flib/core/__init__.php'). +% ex: require_module('flib/core/__init__.php', 'core/db'). +% We don't differentiate 'include' from 'require'. Note that include works +% on desugared flib code so the require_module() are translated in +% their equivalent includes. Finally path are resolved statically +% when we can, so for instance include $THRIFT_ROOT . '...' is resolved +% in its final path form 'lib/thrift/...'. +% +% - yield/1. +% +% - position: at/3 +% ex: at(('Preparable', 'gen'), 'flib/core/preparable.php', 10). +% +% - file information: file/2, hh/2 +% ex: file('wap/index.php', ['wap','index.php']). +% ex: hh('flib/x/foo.php', strict). +% By having a list one then use member/3 to select subparts of the codebase +% easily (or use explode_file/2). +% +% related work: +% - jquery, tyruba +% - CIA +% - ODASA, codequest +% - LFS/PofFS +% +% limitations: +% - in the case of PHP, the language is case insensitive but we actually +% generate facts where the case matters. You can use downcase_atom/2 +% to try to do case insensitive search, e.g. +% ? kind(X, class), downcase_atom(X, Y), Y = 'exception', +% but this will work only for the first level. If in the code +% some extends or implements are using the wrong case, you're lost. + +%--------------------------------------------------------------------------- +% How to run/compile +%--------------------------------------------------------------------------- + +% Generates a /tmp/facts.pl for your codebase for your programming language +% (e.g. with pfff_db_heavy -gen_prolog_db /tmp/pfff_db /tmp/facts.pl) +% and then: +% +% $ swipl -s /tmp/facts.pl -f prolog_code.pl +% +% If you want to test a new predicate you can do for instance: +% +% $ swipl -s /tmp/facts.pl -f prolog_code.pl -t halt --quiet -g "children(X,'Foo'), writeln(X), fail" +% +% If you want to compile a database do: +% +% $ swipl -c /tmp/facts.pl prolog_code.pl #this will generate a 'a.out' +% +% Finally you can also use a precompiled database with: +% +% $ cmf --prolog or /home/engshare/pfff/prolog_www +% + +%--------------------------------------------------------------------------- +% Inheritance +%--------------------------------------------------------------------------- + +extends_or_implements(Child, Parent) :- + extends(Child, Parent). +extends_or_implements(Child, Parent) :- + implements(Child, Parent). + +extends_or_mixins(Child, Parent) :- + extends(Child, Parent). +extends_or_mixins(Class, Trait) :- + mixins(Class, Trait). + + +public_or_protected(X) :- + is_public(X). +public_or_protected(X) :- + is_protected(X). + +method_or_field(method). +method_or_field(field). + + +children(Child, Parent) :- + extends_or_implements(Child, Parent). +children(GrandChild, Parent) :- + extends_or_implements(GrandChild, Child), + children(Child, Parent). +children(GrandChild, Parent) :- + mixins(GrandChild, Trait), + children(Trait, Parent). + +%aran: only extends +inherits(Child, Parent) :- + extends(Child, Parent). +inherits(GrandChild, Parent) :- + extends(GrandChild, Child), + inherits(Child, Parent). + +%only for traits +reuses(Child, Trait) :- + mixins(Child, Trait). +reuses(GrandChild, Trait) :- + extends(GrandChild, Child), + reuses(Child, Trait). + +parent(X, Y) :- + children(Y, X). + +% bidirectional +related(X, Y) :- + children(X, Y). +related(X, Y) :- + children(Y, X). + +%--------------------------------------------------------------------------- +% Class information +%--------------------------------------------------------------------------- + +% one can use the same predicate in many ways in Prolog :) +method_in_class(X, Method) :- + kind((X, Method), method). +class_defining_method(Method, X) :- + kind((X, Method), method). + +% get all methods/fields accessible from a class +% todo: for mixins it does not handle yet insteadof and as, but we should +% not use those features anyway. +method(Class, (Class, Method)) :- + kind((Class, Method), method). +method(Class, (Class2, Method)) :- + extends_or_mixins(Class, Parent), + method(Parent, (Class2, Method)), + % ensure we don't count parent implementations of overridden functions + \+ kind((Class, Method), method), + public_or_protected((Class2, Method)). + +field(Class, (Class, Field)) :- + kind((Class, Field), field). +field(Class, (Class2, Field)) :- + extends_or_mixins(Class, Parent), + field(Parent, (Class2, Field)), + public_or_protected((Class2, Field)). + +all_methods(Class) :- findall(X, method(Class, X), XS), writeln(XS). +all_fields(Class) :- findall(X, field(Class, X), XS), writeln(XS). + +% for aran +at_method((Class, Method), File, Line) :- + method(Class, (Class2, Method)), + at((Class2, Method), File, Line). + +% aran's override (shadowed methods) bad smell detector. People should use +% @override to be more explicit. +% todo: need then to extract annotations from php code and generate facts. +overrides(ChildClass, Class, Method) :- + kind((ChildClass, Method), method), + (inherits(ChildClass, Class) ; reuses(ChildClass, Class)), + kind((Class, Method), method). +overrides(ChildClass, Method) :- + overrides(ChildClass, _Class, Method). + +% trait specific overriding +overrides_trait(ChildClass, Method) :- + overrides(ChildClass, Class, Method), + kind(Class, trait). + +%--------------------------------------------------------------------------- +% Callgraph +%--------------------------------------------------------------------------- + +%--------------------------------------------------------------------------- +% Exception +%--------------------------------------------------------------------------- + +% todo: could try to find uncaught exception by using docall, throw, and +% catch predicates? would require a precise callgraph though. + +%--------------------------------------------------------------------------- +% Files +%--------------------------------------------------------------------------- + +explode_file(F, XS) :- + atomic_list_concat(XS, '/', F). + +%--------------------------------------------------------------------------- +% Operators for erling +%--------------------------------------------------------------------------- +calls(A,B) :- docall(A, B, _). +:- op(42, xfx, calls). + +:- op(42, xfx, inherits). + +isa(A,B) :- children(A,B). +:- op(42, xfx, isa). + +%--------------------------------------------------------------------------- +% Statistics +%--------------------------------------------------------------------------- + +% does not work very well with big data :( +%:- use_module(library('R')). +%load_r :- r_open([with(non_interactive)]). + +%--------------------------------------------------------------------------- +% Reporting +%--------------------------------------------------------------------------- + +%--------------------------------------------------------------------------- +% Clown code +%--------------------------------------------------------------------------- + +%todo: histogram for kent of function arities :) +too_many_params(X) :- + arity(X, N), N > 20. + +include_not_www_code(X, Y) :- + include(X, Y), + \+ file(Y, _). + +% this is what makes the callgraph for methods more complicated +same_method_in_unrelated_classes(Method, Class1, Class2) :- + kind((Class1, Method), method), + kind((Class2, Method), method), + Method \= '__construct', + Class1 \= Class2, + \+ related(Class1, Class2). + +%classes with more than 10 public methods: http://en.wikipedia.org/wiki/.QL +too_many_public_methods(X) :- + kind(X, class), + findall(M, (kind((X, M), method), public((X,M))), Res), + length(Res, N), + N > 10. + +%--------------------------------------------------------------------------- +% Security +%--------------------------------------------------------------------------- + +scary('XSS'). +scary('POTENTIAL_XSS_HOLE'). +scary('ToXHP_UNSAFE'). + +%--------------------------------------------------------------------------- +% Refactoring opportunities +%--------------------------------------------------------------------------- + +% aran's code +could_be_final(Class) :- + kind(Class, class), + not(final(Class)), + not(extends(_Child, Class)). + +could_be_final(Class, Method) :- + kind(Class, class), + kind((Class, Method), method), + not(final((Class, Method))), + not(overrides(_ChildClass, Class, Method)). + +% for paul +could_remove_delegate_method(Class, Method) :- + docall((Class, Method), 'delegateToYield', method), + not((children(Class, Parent), kind((Parent, Method), _Kind))). + +%--------------------------------------------------------------------------- +% checks +%--------------------------------------------------------------------------- + +check_exception_inheritance(X) :- + throw(_, X), + not(children(X, 'Exception')), + X \= 'Exception', + % make sure it's defined + kind(X, class). + +check_duplicated_entity(X, File1, File2, Kind) :- + kind(X, Kind), + at(X, File1, _), + at(X, File2, _), + File1 \= File2. + +check_duplicated_field(Class, Class2, Var) :- + kind((Class,Var), field), + public_or_protected((Class, Var)), + Class \= 'Exception', + children(Class2, Class), + kind((Class2, Var), field). + +check_call_unexisting_method_anywhere(Caller, Method) :- + docall(Caller, Method, method), + not(kind((_X, Method), method)). + +% for paul +wrong_public_genRender(X) :- + kind((X, 'genRender'), _), + children(X, 'GenXHP'), + is_public((X, 'genRender')). + +%todo: +% check for inconsistent case, e.g. Exception vs exception. +% just check if 2 classes are different but downcase to the same name + + +:- discontiguous mixins/2. +:- discontiguous implements/2. diff --git a/h_program-lang/refactoring_code.ml b/h_program-lang/refactoring_code.ml new file mode 100644 index 0000000..bfa485a --- /dev/null +++ b/h_program-lang/refactoring_code.ml @@ -0,0 +1,77 @@ +(* Yoann Padioleau + * + * Copyright (C) 2012, 2013 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + + +type refactoring_kind = + | AddInterface of string option (* specific class *) + * string (* the interface to add *) + | RemoveInterface of string option * string + + | SplitMembers + (* todo: Rename of entity * entity *) + + (* type related *) + | AddReturnType of string + | AddTypeHintParameter of string + | OptionizeTypeParameter + | AddTypeMember of string + +type position = { + file: Common.filename; + line: int; + col: int; +} + +type refactoring = refactoring_kind * position option + +(*****************************************************************************) +(* IO *) +(*****************************************************************************) + +(* format: file;RETURN;line;col;value *) +let load file = + Common.cat file +> List.map (fun s -> + let xs = Common.split ";" s in + match xs with + | [file;action;line;col;value] when + line =~ "[0-9]+" && col =~ "[0-9]+" && + (List.mem action [ + "RETURN";"PARAM";"MEMBER"; "MAKE_OPTION_TYPE"; "SPLIT_MEMBERS"; + ]) -> + (match action with + | "RETURN" -> AddReturnType value + | "PARAM" -> AddTypeHintParameter value + | "MEMBER" -> AddTypeMember value + | "MAKE_OPTION_TYPE" -> OptionizeTypeParameter + | "SPLIT_MEMBERS" -> SplitMembers + | _ -> raise Impossible + ), Some + { file; + line = int_of_string line; + col = int_of_string col; + } + + | _ -> failwith ("wrong format for refactoring action: " ^ s) + ) + diff --git a/h_program-lang/refactoring_code.mli b/h_program-lang/refactoring_code.mli new file mode 100644 index 0000000..76f9c6c --- /dev/null +++ b/h_program-lang/refactoring_code.mli @@ -0,0 +1,26 @@ + +(* many refactorings can be done by spatch! used this code only as + * last resort + *) +type refactoring_kind = + | AddInterface of string option (* specific class *) + * string (* the interface to add *) + | RemoveInterface of string option * string + + | SplitMembers + + (* type related *) + | AddReturnType of string + | AddTypeHintParameter of string + | OptionizeTypeParameter + | AddTypeMember of string + +type position = { + file: Common.filename; + line: int; + col: int; +} + +type refactoring = refactoring_kind * position option + +val load: Common.filename -> refactoring list diff --git a/h_program-lang/scope_code.ml b/h_program-lang/scope_code.ml new file mode 100644 index 0000000..8faaebd --- /dev/null +++ b/h_program-lang/scope_code.ml @@ -0,0 +1,84 @@ +(* Yoann Padioleau + * + * Copyright (C) 2009-2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * It would be more convenient to move this file elsewhere like in analyse_xxx/ + * but we want our AST to contain scope annotations so it's convenient to + * have the type definition of scope there. + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* todo? could use open polymorphic variant for that ? the scoping will + * be differerent for each language but they will also have stuff + * in common which may be a good spot for open polymorphic variant. + *) +type scope = + | Global + | Local + | Param + | Static + + | Class + + | LocalExn + | LocalIterator + + (* php specific? *) + | ListBinded + (* closure, could be same as Local, but can be good to visually + * differentiate them in codemap + *) + | Closed + + | NoScope + +(*****************************************************************************) +(* String-of *) +(*****************************************************************************) + +let string_of_scope = function + | Global -> "Global" + | Local -> "Local" + | Param -> "Param" + | Static -> "Static" + | Class -> "Class" + | LocalExn -> "LocalExn" + | LocalIterator -> "LocalIterator" + | ListBinded -> "ListBinded" + | Closed -> "Closed" + | NoScope -> "NoScope" + +(*****************************************************************************) +(* Meta *) +(*****************************************************************************) + +let vof_scope x = + match x with + | Global -> Ocaml.VSum (("Global", [])) + | Local -> Ocaml.VSum (("Local", [])) + | Param -> Ocaml.VSum (("Param", [])) + | Static -> Ocaml.VSum (("Static", [])) + | Class -> Ocaml.VSum (("Class", [])) + | LocalExn -> Ocaml.VSum (("LocalExn", [])) + | LocalIterator -> Ocaml.VSum (("LocalIterator", [])) + | ListBinded -> Ocaml.VSum (("ListBinded", [])) + | Closed -> Ocaml.VSum (("Closed", [])) + | NoScope -> Ocaml.VSum (("NoScope", [])) diff --git a/h_program-lang/scope_code.mli b/h_program-lang/scope_code.mli new file mode 100644 index 0000000..64c2b0c --- /dev/null +++ b/h_program-lang/scope_code.mli @@ -0,0 +1,12 @@ + +type scope = + | Global | Local | Param | Static | Class + + | LocalExn | LocalIterator + | ListBinded + | Closed + + | NoScope + +val string_of_scope: scope -> string +val vof_scope: scope -> Ocaml.v diff --git a/h_program-lang/skip_code.ml b/h_program-lang/skip_code.ml new file mode 100644 index 0000000..1fdc9fa --- /dev/null +++ b/h_program-lang/skip_code.ml @@ -0,0 +1,161 @@ +(* Yoann Padioleau + * + * Copyright (C) 2012 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * It is often useful to skip certain parts of a codebase. Large codebase + * often contains special code that can not be parsed, that contains + * dependencies that should not exist, old code that we don't want + * to analyze, etc. + * + * todo: simplify interface in skip_list.txt file? can infer + * dir or file, and maybe sometimes instead of skip we would like + * to specify the opposite, what we want to keep, so maybe a simple + * +/- syntax would be better. + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* the filename are in readable path format *) +type skip = + | Dir of Common.dirname + | File of Common.filename + | DirElement of Common.dirname + | SkipErrorsDir of Common.dirname + +(*****************************************************************************) +(* IO *) +(*****************************************************************************) +let load file = + Common.cat file + +> Common.exclude (fun s -> + s =~ "#.*" || s =~ "^[ \t]*$" + ) + +> List.map (fun s -> + match s with + | _ when s =~ "^dir:[ ]*\\([^ ]+\\)" -> + Dir (Common.matched1 s) + | _ when s =~ "^skip_errors_dir:[ ]*\\([^ ]+\\)" -> + SkipErrorsDir (Common.matched1 s) + | _ when s =~ "^file:[ ]*\\([^ ]+\\)" -> + File (Common.matched1 s) + | _ when s =~ "^dir_element:[ ]*\\([^ ]+\\)" -> + DirElement (Common.matched1 s) + | _ -> failwith ("wrong line format in skip file: " ^ s) + ) + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +(* less: say when skipped stuff? *) +let filter_files skip_list root xs = + let skip_files = + skip_list +> Common.map_filter (function + | File s -> Some s + | _ -> None + ) +> Common.hashset_of_list + in + let skip_dirs = + skip_list +> Common.map_filter (function + | Dir s -> Some s + | _ -> None + ) + in + let skip_dir_elements = + skip_list +> Common.map_filter (function + | DirElement s -> Some s + | _ -> None + ) + in + xs +> Common.exclude (fun file -> + let readable = Common.readable ~root file in + (Hashtbl.mem skip_files readable) || + (skip_dirs +> List.exists + (fun dir -> readable =~ (dir ^ ".*"))) || + (skip_dir_elements +> List.exists + (fun dir -> readable =~ (".*/" ^ dir ^ "/.*"))) + ) + + +(* copy paste of h_version_control/git.ml *) +let find_vcs_root_from_absolute_path file = + let xs = Common.split "/" (Common2.dirname file) in + let xxs = Common2.inits xs in + xxs +> List.rev +> Common.find_some (fun xs -> + let dir = "/" ^ Common.join "/" xs in + if Sys.file_exists (Filename.concat dir ".git") || + Sys.file_exists (Filename.concat dir ".hg") || + false + then Some dir + else None + ) + +let find_skip_file_from_root root = + let candidates = [ + "skip_list.txt"; + (* fbobjc specific *) + "Configurations/Sgrep/skip_list.txt"; + (* www specific *) + "conf/codegraph/skip_list.txt"; + ] + in + candidates +> Common.find_some (fun f -> + let full = Filename.concat root f in + if Sys.file_exists full + then Some full + else None + ) + +let filter_files_if_skip_list xs = + match xs with + | [] -> [] + | x::_ -> + try + let root = find_vcs_root_from_absolute_path x in + let skip_file = find_skip_file_from_root root in + let skip_list = load skip_file in + pr2 (spf "using skip list in %s" skip_file); + filter_files skip_list root xs + with Not_found -> xs + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) +let build_filter_errors_file skip_list = + let skip_dirs = + skip_list +> Common.map_filter (function + | SkipErrorsDir dir -> Some dir + | _ -> None + ) + in + (fun readable -> + skip_dirs +> List.exists (fun dir -> readable =~ ("^" ^ dir)) + ) + +let reorder_files_skip_errors_last skip_list root xs = + let is_file_want_to_skip_error = build_filter_errors_file skip_list in + let (skip_errors, ok) = + xs +> List.partition (fun file -> + let readable = Common.readable ~root file in + is_file_want_to_skip_error readable + ) + in + ok @ skip_errors diff --git a/h_program-lang/skip_code.mli b/h_program-lang/skip_code.mli new file mode 100644 index 0000000..25f5de6 --- /dev/null +++ b/h_program-lang/skip_code.mli @@ -0,0 +1,26 @@ + +type skip = + (* mostly to avoid parsing errors messages *) + | Dir of Common.dirname + | File of Common.filename + | DirElement of Common.dirname + | SkipErrorsDir of Common.dirname + +val load: Common.filename -> skip list + +val filter_files: + skip list -> Common.dirname (* root *) -> Common.filename list -> + Common.filename list + +(* assumes given full paths *) +val filter_files_if_skip_list: + Common.filename list -> Common.filename list + +val reorder_files_skip_errors_last: + skip list -> Common.dirname (* root *) -> Common.filename list -> + Common.filename list + +(* returns true if we should skip the file for errors *) +val build_filter_errors_file: + skip list -> (Common.filename (* readable *) -> bool) + diff --git a/h_program-lang/tags_file.ml b/h_program-lang/tags_file.ml new file mode 100644 index 0000000..8665615 --- /dev/null +++ b/h_program-lang/tags_file.ml @@ -0,0 +1,237 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010-2012 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module PI = Parse_info +module E = Entity_code + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Generating TAGS file (for emacs or vim) + * + * Supposed syntax for emacs TAGS (.tags) files, as analysed from output + * of etags, read in etags.c and discussed with Francesco Potorti. + * src: otags readme: + * + * ::= + + * ::=
+ *
::= , + * ::= * + * ::= , + * pad: when tag is already at the beginning of the line: + * ::=, + * + * ::= ascii NP, (emacs ^L) + * ::= ascii DEL, (emacs ^?) + * ::= ascii SOH, (emacs ^A) + * :: ascii CR + * + * See also http://en.wikipedia.org/wiki/Ctags#Tags_file_formats + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* see http://en.wikipedia.org/wiki/Ctags#Tags_file_formats *) +let header = "\x0c\n" + +let footer = "" + +type tag = { + tag_definition_text: string; + tagname: string; + line_number: int; + (* offset of beginning of tag_definition_text, when have 0-indexed filepos *) + byte_offset: int; + (* only used by vim *) + kind: Entity_code.entity_kind; +} + +let mk_tag s1 s2 i1 i2 k = { + tag_definition_text = s1; + tagname = s2; + line_number = i1; + byte_offset = i2; + kind = k; +} + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let string_of_tag t = + spf "%s\x7f%s\x01%d,%d\n" + t.tag_definition_text + t.tagname + t.line_number + t.byte_offset + +(* of tests/misc/functions.php *) +(* +let fake_defs = [ + mk_tag "function a() {" "a" 3 7; + mk_tag "function b() {" "b" 7 32; + mk_tag "function c() {" "c" 14 65; + mk_tag "function d() {" "d" 20 107; +] +*) + +(* helpers used externally by language taggers *) +let tag_of_info filelines info kind = + let line = PI.line_of_info info in + let pos = PI.pos_of_info info in + let col = PI.col_of_info info in + let s = PI.str_of_info info in + mk_tag (filelines.(line)) s line (pos - col) kind + +(* C-s for "kind" in http://ctags.sourceforge.net/FORMAT *) +let vim_tag_kind_str tag_kind = + match tag_kind with + | E.Class -> "c" + | E.Constant -> "d" + | E.Function -> "f" + | E.Method -> "f" + | E.Type -> "t" + | E.Field -> "m" + + | E.Module | E.Package + | E.Global | E.Macro + | E.TopStmts + | E.Other _ + | E.ClassConstant + | E.Constructor + + | E.File | E.Dir | E.MultiDirs + | E.Exception + | E.Prototype | E.GlobalExtern + -> "" + +(* vim uses '/' as a marker for the tag definition text, so if this + * test contains '/' they must be escaped. + *) +let vim_escape_slash str = + Str.global_replace (Str.regexp "/") "\\/" str + + +(* For methods, in addition to the tag for the precise 'class::method' + * name, it can be convenient to generate another tag with just the + * 'method' name so people can quickly jump to some code with just the + * method name. Of course if there is also a function somewhere using the + * same name then this function could be hard to reach so we generate + * an (imprecise) method tag only when there is no ambiguity. + *) +let add_method_tags_when_unambiguous files_and_defs = + + (* step1: global analysis on all defs, remember all names and methods *) + let h_toplevel_names = + files_and_defs +> List.map (fun (_file, tags) -> + tags +> Common.map_filter (fun t -> + match t.kind with + | E.Class | E.Function | E.Constant -> Some t.tagname + | _ -> None + ) + ) +> List.flatten +> Common.hashset_of_list + in + let h_grouped_methods = + files_and_defs +> List.map (fun (_file, tags) -> + tags +> Common.map_filter (fun t -> + match t.kind with + | E.Method -> + if t.tagname =~ ".*::\\(.*\\)" + then Some (Common.matched1 t.tagname, t) + else failwith ("method tag should contain '::[, got: " ^ t.tagname) + | _ -> None + ) + (* could skip the group_assoc_bykey and do Hashtbl.find_all below instead *) + ) +> List.flatten +> Common.group_assoc_bykey_eff +> Common.hash_of_list + in + (* step2: add method tag when no ambiguity *) + files_and_defs +> List.map (fun (file, tags) -> + file, + tags +> List.map (fun t -> + match t.kind with + | E.Method -> + if t.tagname =~ ".*::\\(.*\\)" + then + let methodname = Common.matched1 t.tagname in + if not (Hashtbl.mem h_toplevel_names methodname) && + List.length (Hashtbl.find h_grouped_methods methodname) = 1 + then [t; { t with tagname = methodname }] + else [t] + else failwith("method tag should contain '::[, got: " ^ t.tagname) + | _ -> [t] + ) +> List.flatten + ) + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +let threshold_long_line = 1000 + +let generate_TAGS_file tags_file files_and_defs = + Common.with_open_outfile tags_file (fun (pr_no_nl, _chan) -> + pr_no_nl header; + files_and_defs +> List.iter (fun (file, defs) -> + let all_defs = defs +> Common.map_filter (fun tag -> + if String.length tag.tag_definition_text > threshold_long_line + then begin + pr2_once (spf "WEIRD long string in %s, passing the tag" file); + None + end + else Some (string_of_tag tag) + ) +> Common.join "" in + let size_defs = String.length all_defs in + pr_no_nl (spf "%s,%d\n" file size_defs); + pr_no_nl all_defs; + pr_no_nl "\x0c\n"; + ); + ); + () + +(* http://vimdoc.sourceforge.net/htmldoc/tagsrch.html#tags-file-format *) +let generate_vi_tags_file tags_file files_and_defs = + Common.with_open_outfile tags_file (fun (pr_no_nl, _chan) -> + + let all_tags = + files_and_defs +> List.map (fun (file, defs) -> + defs +> Common.map_filter (fun tag -> + if String.length tag.tag_definition_text > 300 + then begin + pr2 (spf "WEIRD long string in %s, passing the tag" file); + None + end + else Some (tag.tagname, (tag, file)) + )) + +> List.flatten + +> Common.sort_by_key_lowfirst + in + all_tags +> List.iter (fun (_tagname, (tag, file)) -> + (* {tagname}{tagfile}{tagaddress} + * "The two characters semicolon and double quote [...] are + * interpreted by Vi as the start of a comment, which makes the + * following be ignored." + *) + pr_no_nl (spf "%s\t%s\t/%s/;\"\t%s\n" + tag.tagname + file + (vim_escape_slash tag.tag_definition_text) + (vim_tag_kind_str tag.kind) + ); + ); + ) diff --git a/h_program-lang/tags_file.mli b/h_program-lang/tags_file.mli new file mode 100644 index 0000000..e49934a --- /dev/null +++ b/h_program-lang/tags_file.mli @@ -0,0 +1,31 @@ + +type tag = { + tag_definition_text: string; + tagname: string; + line_number: int; + (* offset of beginning of tag_definition_text, when have 0-indexed filepos *) + byte_offset: int; + (* only used by vim *) + kind: Entity_code.entity_kind; +} + +(* will generate a TAGS file in the current directory *) +val generate_TAGS_file: + Common.filename -> (Common.filename * tag list) list -> unit +(* will generate a tags file in the current directory *) +val generate_vi_tags_file: + Common.filename -> (Common.filename * tag list) list -> unit + +val add_method_tags_when_unambiguous: + (Common.filename * tag list) list -> (Common.filename * tag list) list + +(* internals *) +val mk_tag: string -> string -> int -> int -> Entity_code.entity_kind -> tag + +val string_of_tag: tag -> string +val header: string +val footer: string + +(* helpers used by language taggers *) +val tag_of_info: + string array -> Parse_info.info -> Entity_code.entity_kind -> tag diff --git a/h_program-lang/test_program_lang.ml b/h_program-lang/test_program_lang.ml new file mode 100644 index 0000000..4436666 --- /dev/null +++ b/h_program-lang/test_program_lang.ml @@ -0,0 +1,83 @@ +open Common + +module Db = Database_code +module E = Entity_code + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +(*****************************************************************************) +(* Subsystem testing *) +(*****************************************************************************) + +let test_load_light_db file = + let _db = Db.load_database file in + () + +let test_big_grep file = + let db = Db.load_database file in + let entities = + Db.files_and_dirs_and_sorted_entities_for_completion + ~threshold_too_many_entities:300000 + db in + let idx = Big_grep.build_index entities in + let query = "old_le" in + let top_n = 10 in + + let xs = Big_grep.top_n_search ~top_n ~query idx in + + xs +> List.iter (fun e -> +(* + let json = Db.json_of_entity e in + let s = Json_io.string_of_json json in + pr2 s +*) + pr2_gen e; + ); + + (* naive search *) + let xs = Big_grep.naive_top_n_search ~top_n ~query entities in + xs +> List.iter (fun e -> +(* + let json = Db.json_of_entity e in + let s = Json_io.string_of_json json in + pr2 s +*) + pr2_gen e + ); + () + +let test_layer file = + let layer = Layer_code.load_layer file in + let json = Layer_code.json_of_layer layer in + let s = Json_out.string_of_json json in + pr2 s + +let layer_stat file = + let layer = Layer_code.load_layer file in + let stats = Layer_code.stat_of_layer layer in + stats +> List.iter (fun (k, v) -> + pr (spf " %s = %d" k v) + ) + +let test_refactoring file = + let xs = Refactoring_code.load file in + xs +> List.iter pr2_gen; + () + + +(*****************************************************************************) +(* Main entry for Arg *) +(*****************************************************************************) + +let actions () = [ + "-test_load_db", " ", + Common.mk_action_1_arg test_load_light_db; + "-test_big_grep", " ", + Common.mk_action_1_arg test_big_grep; + "-test_layer", " ", + Common.mk_action_1_arg test_layer; + "-test_refactoring", " ", + Common.mk_action_1_arg test_refactoring; +] diff --git a/h_program-lang/test_program_lang.mli b/h_program-lang/test_program_lang.mli new file mode 100644 index 0000000..683653d --- /dev/null +++ b/h_program-lang/test_program_lang.mli @@ -0,0 +1,5 @@ + +val layer_stat: Common.filename -> unit + +val actions: unit -> Common.cmdline_actions + diff --git a/h_program-lang/unit_program_lang.ml b/h_program-lang/unit_program_lang.ml new file mode 100644 index 0000000..dfb9cdb --- /dev/null +++ b/h_program-lang/unit_program_lang.ml @@ -0,0 +1,19 @@ +open OUnit + +module E = Entity_code + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +(*****************************************************************************) +(* Data *) +(*****************************************************************************) + +(*****************************************************************************) +(* Unit tests *) +(*****************************************************************************) + +let unittest = + "program_lang" >::: [ + ] diff --git a/h_program-lang/unit_program_lang.mli b/h_program-lang/unit_program_lang.mli new file mode 100644 index 0000000..1154f56 --- /dev/null +++ b/h_program-lang/unit_program_lang.mli @@ -0,0 +1,6 @@ + +(* Returns the testsuite for this directory. To be concatenated by + * the caller (e.g. in pfff/main_test.ml ) with other testsuites and + * run via OUnit.run_test_tt(). + *) +val unittest: OUnit.test diff --git a/lang_c/parsing/.depend b/lang_c/parsing/.depend new file mode 100644 index 0000000..3de73cc --- /dev/null +++ b/lang_c/parsing/.depend @@ -0,0 +1,49 @@ +ast_c.cmo : ../../commons/common2.cmi ../../commons/common.cmi \ + ../../lang_cpp/parsing/ast_cpp.cmo +ast_c.cmx : ../../commons/common2.cmx ../../commons/common.cmx \ + ../../lang_cpp/parsing/ast_cpp.cmx +ast_c_simple_build.cmo : ../../h_program-lang/parse_info.cmi \ + ../../commons/ocaml.cmi ../../lang_cpp/parsing/meta_ast_cpp.cmi \ + ../../commons/common2.cmi ../../commons/common.cmi \ + ../../lang_cpp/parsing/ast_cpp.cmo ast_c.cmo ast_c_simple_build.cmi +ast_c_simple_build.cmx : ../../h_program-lang/parse_info.cmx \ + ../../commons/ocaml.cmx ../../lang_cpp/parsing/meta_ast_cpp.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx \ + ../../lang_cpp/parsing/ast_cpp.cmx ast_c.cmx ast_c_simple_build.cmi +ast_c_simple_build.cmi : ../../h_program-lang/parse_info.cmi \ + ../../lang_cpp/parsing/ast_cpp.cmo ast_c.cmo +lib_parsing_c.cmo : visitor_c.cmo ../../commons/file_type.cmi \ + ../../commons/common.cmi lib_parsing_c.cmi +lib_parsing_c.cmx : visitor_c.cmx ../../commons/file_type.cmx \ + ../../commons/common.cmx lib_parsing_c.cmi +lib_parsing_c.cmi : ../../h_program-lang/parse_info.cmi \ + ../../commons/common.cmi ast_c.cmo +meta_ast_c.cmo : ../../h_program-lang/parse_info.cmi ../../commons/ocaml.cmi \ + ../../lang_cpp/parsing/ast_cpp.cmo ast_c.cmo meta_ast_c.cmi +meta_ast_c.cmx : ../../h_program-lang/parse_info.cmx ../../commons/ocaml.cmx \ + ../../lang_cpp/parsing/ast_cpp.cmx ast_c.cmx meta_ast_c.cmi +meta_ast_c.cmi : ../../commons/ocaml.cmi ast_c.cmo +parse_c.cmo : ../../lang_cpp/parsing/parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi ../../lang_cpp/parsing/parse_cpp.cmi \ + ../../lang_cpp/parsing/flag_parsing_cpp.cmo ../../commons/common2.cmi \ + ../../commons/common.cmi ast_c_simple_build.cmi ast_c.cmo parse_c.cmi +parse_c.cmx : ../../lang_cpp/parsing/parser_cpp.cmx \ + ../../h_program-lang/parse_info.cmx ../../lang_cpp/parsing/parse_cpp.cmx \ + ../../lang_cpp/parsing/flag_parsing_cpp.cmx ../../commons/common2.cmx \ + ../../commons/common.cmx ast_c_simple_build.cmx ast_c.cmx parse_c.cmi +parse_c.cmi : ../../lang_cpp/parsing/parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi ../../commons/common.cmi ast_c.cmo +test_parsing_c.cmo : ../../h_program-lang/parse_info.cmi parse_c.cmi \ + ../../commons/ocaml.cmi meta_ast_c.cmi lib_parsing_c.cmi \ + ../../commons/common.cmi test_parsing_c.cmi +test_parsing_c.cmx : ../../h_program-lang/parse_info.cmx parse_c.cmx \ + ../../commons/ocaml.cmx meta_ast_c.cmx lib_parsing_c.cmx \ + ../../commons/common.cmx test_parsing_c.cmi +test_parsing_c.cmi : ../../commons/common.cmi +unit_parsing_c.cmo : unit_parsing_c.cmi +unit_parsing_c.cmx : unit_parsing_c.cmi +unit_parsing_c.cmi : +visitor_c.cmo : ../../commons/ocaml.cmi ../../lang_cpp/parsing/ast_cpp.cmo \ + ast_c.cmo +visitor_c.cmx : ../../commons/ocaml.cmx ../../lang_cpp/parsing/ast_cpp.cmx \ + ast_c.cmx diff --git a/lang_c/parsing/Makefile b/lang_c/parsing/Makefile new file mode 100644 index 0000000..7db3142 --- /dev/null +++ b/lang_c/parsing/Makefile @@ -0,0 +1,60 @@ +TOP=../.. +############################################################################## +# Variables +############################################################################## +TARGET=lib + +-include $(TOP)/Makefile.config + +SRC= ast_c.ml meta_ast_c.ml visitor_c.ml \ + ast_c_simple_build.ml \ + lib_parsing_c.ml \ + parse_c.ml \ + test_parsing_c.ml unit_parsing_c.ml \ + +SYSLIBS= str.cma unix.cma + +LIBS=$(TOP)/commons/lib.cma \ + $(TOP)/h_program-lang/lib.cma \ + $(TOP)/lang_cpp/parsing/lib.cma + +INCLUDEDIRS= \ + $(TOP)/commons\ + $(TOP)/globals \ + $(TOP)/h_program-lang \ + $(TOP)/lang_cpp/parsing \ + +############################################################################## +# Generic variables +############################################################################## + +-include $(TOP)/Makefile.common + +############################################################################## +# Top rules +############################################################################## +all:: $(TARGET).cma +all.opt:: $(TARGET).cmxa + +$(TARGET).cma: $(OBJS) + $(OCAMLC) -a -o $(TARGET).cma $(OBJS) + +$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa) + $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS) + +$(TARGET).top: $(OBJS) $(LIBS) + $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS) + +clean:: + rm -f $(TARGET).top + +visitor_c.cmo: visitor_c.ml + $(OCAMLC) -w y -c $< + +############################################################################## +# Generic rules +############################################################################## + +############################################################################## +# Literate Programming rules +############################################################################## diff --git a/lang_c/parsing/ast_c.ml b/lang_c/parsing/ast_c.ml new file mode 100644 index 0000000..533d037 --- /dev/null +++ b/lang_c/parsing/ast_c.ml @@ -0,0 +1,305 @@ +(* Yoann Padioleau + * + * Copyright (C) 2012, 2014 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common2.Infix + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * A (real) Abstract Syntax Tree for C, not a Concrete Syntax Tree + * as in ast_cpp.ml. + * + * This file contains a simplified C abstract syntax tree. The original + * C/C++ syntax tree (ast_cpp.ml) is good for code refactoring or + * code visualization; the types used match exactly the source. However, + * for other algorithms, the nature of the AST makes the code a bit + * redundant. Moreover many analysis are far simpler to write on + * C than C++. Hence the idea of a SimpleAST which is the + * original AST where certain constructions have been factorized + * or even removed. + + * Here is a list of the simplications/factorizations: + * - no C++ constructs, just plain C + * - no purely syntactical tokens in the AST like parenthesis, brackets, + * braces, commas, semicolons, etc. No ParenExpr. No FinalDef. No + * NotParsedCorrectly. The only token information kept is for identifiers + * for error reporting. See name below. + * - ... + * - no nested struct, they are lifted to the toplevel + * - no anonymous structure (an artificial name is gensym'ed) + * - no mix of typedef with decl + * - sugar is removed, no RecordAccess vs RecordPtAccess, ... + * - no init vs expr + * - no Case/Default in statement but instead a focused 'case' type + * + * less: ast_c_simple_build.ml is probably incomplete, but for now + * is good enough for codegraph purposes on xv6, plan9 and other small C + * projects. + * + * related work: + * - CIL, but it works after preprocessing; it makes it harder to connect + * analysis results to tools like codemap. It also does not handle some of + * the kencc extensions and does not allow to analyze cpp constructs. + * CIL has two pointer analysis but they were written with bug finding + * in mind I think, not code comprehension which we really care about + * in pfff. + * In the end I thought generating datalog facts for plan9 using lang_c/ + * was simpler that modifying CIL (moreover fixing lang_cpp/ and lang_c/ + * to handle plan9 code was anyway needed for codemap). + * - SIL's monoidics. SIL looks a bit complicated, but it might be a good + * candidate, unforunately their API are not easily accessible in + * a findlib library form yet. + * - Clang, but like CIL it works after preprocessing, does not handle kencc, + * and does not provide by default a convenient ocaml AST. I could use + * clang-ocaml though but it's not easily accessible in a findlib + * library form yet. + * - we could also use the AST used by cc in plan9 :) + * + * See lang_cpp/parsing/ast_cpp.ml. + * + *) + +(*****************************************************************************) +(* The AST related types *) +(*****************************************************************************) + +type 'a wrap = 'a * Ast_cpp.tok + +(* ------------------------------------------------------------------------- *) +(* Name *) +(* ------------------------------------------------------------------------- *) + +type name = string wrap + (* with tarzan *) + +(* ------------------------------------------------------------------------- *) +(* Types *) +(* ------------------------------------------------------------------------- *) + +(* less: qualifier (const/volatile) *) +type type_ = + | TBase of name (* int, float, etc *) + | TPointer of type_ + | TArray of const_expr option * type_ + | TFunction of function_type + | TStructName of struct_kind * name + (* hmmm but in C it's really like an int no? but scheck could be + * extended at some point to do more strict type checking! + *) + | TEnumName of name + | TTypeName of name + + (* less: '...' varargs support *) + and function_type = (type_ * parameter list) + + and parameter = { + p_type: type_; + (* when part of a prototype, the name is not always mentionned *) + p_name: name option; + } + + and struct_kind = Struct | Union + +(* ------------------------------------------------------------------------- *) +(* Expression *) +(* ------------------------------------------------------------------------- *) +and expr = + | Int of string wrap + | Float of string wrap + | String of string wrap + | Char of string wrap + + (* can be a cpp or enum constant (e.g. FOO), or a local/global/parameter + * variable, or a function name. + *) + | Id of name + + | Call of expr * argument list + + (* should be a statement ... but see Datalog_c.instr *) + | Assign of Ast_cpp.assignOp wrap * expr * expr + + | ArrayAccess of expr * expr (* x[y] *) + (* Why x->y instead of x.y choice? it's easier then with datalog + * and it's more consistent with ArrayAccess where expr has to be + * a kind of pointer too. That means x.y is actually unsugared in (&x)->y + *) + | RecordPtAccess of expr * name (* x->y, and not x.y!! *) + + | Cast of type_ * expr + + (* less: transform into Call (builtin ...) ? *) + | Postfix of expr * Ast_cpp.fixOp wrap + | Infix of expr * Ast_cpp.fixOp wrap + (* contains GetRef and Deref!! todo: lift up? *) + | Unary of expr * Ast_cpp.unaryOp wrap + | Binary of expr * Ast_cpp.binaryOp wrap * expr + + | CondExpr of expr * expr * expr + (* should be a statement ... *) + | Sequence of expr * expr + + | SizeOf of (expr, type_) Common.either + + (* should appear only in a variable initializer, or after GccConstructor *) + | ArrayInit of (expr option * expr) list + | RecordInit of (name * expr) list + (* gccext: kenccext: *) + | GccConstructor of type_ * expr (* always an ArrayInit (or RecordInit?) *) + +and argument = expr + +(* really should just contain constants and Id that are #define *) +and const_expr = expr + + (* with tarzan *) + +(* ------------------------------------------------------------------------- *) +(* Statement *) +(* ------------------------------------------------------------------------- *) +type stmt = + | ExprSt of expr + | Block of stmt list + + | If of expr * stmt * stmt + | Switch of expr * case list + + | While of expr * stmt + | DoWhile of stmt * expr + | For of expr option * expr option * expr option * stmt + + | Return of expr option + | Continue | Break + + | Label of name * stmt + | Goto of name + + | Vars of var_decl list + (* todo: it's actually a special kind of format, not just an expr *) + | Asm of expr list + + and case = + | Case of expr * stmt list + | Default of stmt list + +(* ------------------------------------------------------------------------- *) +(* Variables *) +(* ------------------------------------------------------------------------- *) + +and var_decl = { + v_name: name; + v_type: type_; + v_storage: storage; + v_init: initialiser option; +} + (* can have ArrayInit and RecordInit here in addition to other expr *) + and initialiser = expr + and storage = Extern | Static | DefaultStorage + + (* with tarzan *) + +(* ------------------------------------------------------------------------- *) +(* Definitions *) +(* ------------------------------------------------------------------------- *) + +type func_def = { + f_name: name; + f_type: function_type; + f_body: stmt list; + f_static: bool; +} + (* with tarzan *) + + +type struct_def = { + s_name: name; + s_kind: struct_kind; + s_flds: field_def list; +} + (* less: could merge with var_decl, but field have no storage normally *) + and field_def = { + (* less: bitfield annotation + * kenccext: the option on fld_name is for inlined anonymous structure. + *) + fld_name: name option; + fld_type: type_; + } + (* with tarzan *) + +(* less: use a record *) +type enum_def = name * (name * const_expr option) list + (* with tarzan *) + +(* less: use a record *) +type type_def = name * type_ + (* with tarzan *) + +(* ------------------------------------------------------------------------- *) +(* Cpp *) +(* ------------------------------------------------------------------------- *) + +type define_body = + | CppExpr of expr (* actually const_expr when in Define context *) + (* todo: we want that? even dowhile0 are actually transformed in CppExpr. + * We have no way to reference a CppStmt in 'stmt' since MacroStmt + * is not here? So we can probably remove this constructor no? + *) + | CppStmt of stmt + (* with tarzan *) + +(* ------------------------------------------------------------------------- *) +(* Program *) +(* ------------------------------------------------------------------------- *) +type toplevel = + | Include of string wrap (* path *) + | Define of name * define_body + | Macro of name * (name list) * define_body + + (* less: what about ForwardStructDecl? for mutually recursive structures? + * probably can deal with it by using typedefs as intermediates. + *) + | StructDef of struct_def + | TypeDef of type_def + | EnumDef of enum_def + | FuncDef of func_def + | Global of var_decl (* also contain extern decl *) + | Prototype of func_def (* empty body *) + (* with tarzan *) + +type program = toplevel list + (* with tarzan *) + +(* ------------------------------------------------------------------------- *) +(* Any *) +(* ------------------------------------------------------------------------- *) +type any = + | Expr of expr + | Stmt of stmt + | Type of type_ + | Toplevel of toplevel + | Program of program + (* with tarzan *) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let str_of_name (s, _) = s + +let looks_like_macro name = + let s = str_of_name name in + s =~ "^[A-Z][A-Z_0-9]*$" + +let unwrap x = fst x diff --git a/lang_c/parsing/ast_c_simple_build.ml b/lang_c/parsing/ast_c_simple_build.ml new file mode 100644 index 0000000..d3fcb23 --- /dev/null +++ b/lang_c/parsing/ast_c_simple_build.ml @@ -0,0 +1,772 @@ +(* Yoann Padioleau + * + * Copyright (C) 2012, 2014 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +open Ast_cpp +module A = Ast_c + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Ast_cpp to Ast_c_simple. + * + * We skip the then part of ifdefs. + * + * todo: + * - lift up local union and struct defined in functions? + * (hmm but better to rewrite the code I think) + *) + +(*****************************************************************************) +(* Globals *) +(*****************************************************************************) +(* for anon struct, which is dangerous! because the main function + * will return different results given the same input when called + * two times in a row + *) +let cnt = ref 0 + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +exception ObsoleteConstruct of string * Parse_info.info +exception CplusplusConstruct +exception TodoConstruct of string * Parse_info.info +exception CaseOutsideSwitch +exception MacroInCase + +type env = { + mutable struct_defs_toadd: A.struct_def list; + mutable enum_defs_toadd: A.enum_def list; + mutable typedefs_toadd: A.type_def list; +} + +let empty_env () = { + struct_defs_toadd = []; + enum_defs_toadd = []; + typedefs_toadd = []; +} + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let debug any = + let v = Meta_ast_cpp.vof_any any in + let s = Ocaml.string_of_v v in + pr2 s + +let rec ifdef_skipper xs f = + + match xs with + | [] -> [] + | x::xs -> + (match f x with + | None -> x::ifdef_skipper xs f + | Some ifdef -> + (match ifdef with + | Ifdef, tok -> + pr2_once (spf "skipping: %s" (Parse_info.str_of_info tok)); + (try + let (_, x, rest) = + xs +> Common2.split_when (fun x -> + match f x with + | Some (IfdefElse, _) -> true + | Some (IfdefEndif, _) -> true + | _ -> false + ) + in + (match f x with + | Some (IfdefEndif, _) -> + ifdef_skipper rest f + | Some (IfdefElse, _) -> + let (before, _x, rest) = + rest +> Common2.split_when (fun x -> + match f x with + | Some (IfdefEndif, _) -> true + | _ -> false + ) + in + ifdef_skipper before f @ ifdef_skipper rest f + | _ -> raise Impossible + ) + with Not_found -> + failwith (spf "%s: unclosed ifdef" (Parse_info.string_of_info tok)) + ) + | _, tok -> + failwith (spf "%s: no ifdef" (Parse_info.string_of_info tok)) + ) + ) + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +let rec program xs = + let env = empty_env () in + toplevels env xs +> List.flatten + +(* ---------------------------------------------------------------------- *) +(* Toplevels *) +(* ---------------------------------------------------------------------- *) + +and toplevels env xs = + ifdef_skipper xs (function IfdefDecl x -> Some x | _ -> None) + +> List.map (toplevel env) + +and toplevel env x = + match x with + | DeclElem decl -> declaration env decl + | CppDirectiveDecl x -> cpp_directive env x + + | (MacroVarTop (_, _)|MacroTop (_, _, _)) -> + debug (Toplevel x); raise Todo + + | IfdefDecl _ -> raise Impossible (* see ifdef_skipper *) + (* not much we can do here, at least the parsing statistics should warn the + * user that some code was not processed + *) + | NotParsedCorrectly _ -> [] + + +and declaration env x = + match x with + | Func (func_or_else) -> + (match func_or_else with + | FunctionOrMethod def -> + [A.FuncDef (func_def env def)] + | Constructor _ | Destructor _ -> + debug (Toplevel (DeclElem x)); raise CplusplusConstruct + ) + + | BlockDecl bd -> + (match block_declaration env bd with + | A.Vars xs -> + let structs = env.struct_defs_toadd in + let enums = env.enum_defs_toadd in + let typedefs = env.typedefs_toadd in + env.struct_defs_toadd <- []; + env.enum_defs_toadd <- []; + env.typedefs_toadd <- []; + (structs +> List.map (fun x -> A.StructDef x)) @ + (enums +> List.map (fun x -> A.EnumDef x)) @ + (typedefs +> List.map (fun x -> A.TypeDef x)) @ + (xs +> List.map (fun x -> + (* could skip extern declaration? *) + match x with + | { A.v_type = A.TFunction ft; v_storage = storage; _ } -> + A.Prototype { A. + f_name = x.A.v_name; + f_type = ft; + f_static = (storage =*= A.Static); + f_body = []; + } + | _ -> A.Global x + )) + | _ -> + debug (Toplevel (DeclElem x)); raise Todo + ) + + | EmptyDef _ -> [] + + | NameSpaceAnon (_, _)|NameSpaceExtend (_, _)|NameSpace (_, _, _) + | ExternCList (_, _, _)|ExternC (_, _, _)|TemplateSpecialization (_, _, _) + | TemplateDecl _ -> + debug (Toplevel (DeclElem x)); raise CplusplusConstruct + | DeclTodo -> + debug (Toplevel (DeclElem x)); raise Todo + + +(* ---------------------------------------------------------------------- *) +(* Functions *) +(* ---------------------------------------------------------------------- *) +and func_def env def = + { A. + f_name = name env def.f_name; + f_type = function_type env def.f_type; + f_static = + (match def.f_storage with + | Sto (Static, _) -> true + | _ -> false + ); + f_body = compound env def.f_body; + } + +and function_type env x = + match x with + { ft_ret = ret; + ft_params = params; + ft_dots = _dotsTODO; + ft_const = const; + ft_throw = throw; + } -> + (match const, throw with + | None, None -> () + | _ -> raise CplusplusConstruct + ); + + (full_type env ret, + List.map (parameter env) (params +> unparen +> uncomma) + ) + +and parameter env x = + match x with + { p_name = n; + p_type = t; + p_register = _regTODO; + p_val = v; + } -> + (match v with + | None -> () + | Some _ -> debug (Parameter x); raise CplusplusConstruct + ); + { A. + p_name = + (match n with + (* probably a prototype where didn't specify the name *) + | None -> None + | Some (name) -> Some name + ); + p_type = full_type env t; + } + +(* ---------------------------------------------------------------------- *) +(* Variables *) +(* ---------------------------------------------------------------------- *) +and onedecl env d = + match d with + { v_namei = ni; + v_type = ft; + v_storage = sto; + } -> + (match ni, sto with + | Some (n, iopt), (NoSto | Sto _) -> + let init_opt = + match iopt with + | None -> None + | Some (EqInit (_, ini)) -> Some (initialiser env ini) + | Some (ObjInit _) -> + debug (OneDecl d); + raise CplusplusConstruct + in + Some { A. + v_name = name env n; + v_type = full_type env ft; + v_storage = storage env sto; + v_init = init_opt; + } + | Some (n, None), (StoTypedef _) -> + let def = (name env n, full_type env ft) in + env.typedefs_toadd <- def :: env.typedefs_toadd; + None + | None, NoSto -> + (match Ast_cpp.unwrap_typeC ft with + (* it's ok to not have any var decl as long as a type + * was defined. struct_defs_toadd should not be empty then. + *) + | StructDef _ | EnumDef _ -> + let _ = full_type env ft in + None + (* forward declaration *) + | StructUnionName _ -> + None + + | _ -> debug (OneDecl d); raise Todo + ) + | _ -> debug (OneDecl d); raise Todo + ) + +and initialiser env x = + match x with + | InitExpr e -> expr env e + | InitList xs -> + (match xs +> unbrace +> uncomma with + | [] -> debug (Init x); raise Impossible + | (InitDesignators ([DesignatorField (_, _)], _, _init))::_ -> + A.RecordInit ( + xs +> unbrace +> uncomma +> List.map (function + | InitDesignators ([DesignatorField (_, ident)], _, init) -> + ident, initialiser env init + | _ -> debug (Init x); raise Todo + )) + | _ -> + A.ArrayInit ((xs +> unbrace +> uncomma) +> List.map (function + (* less: todo? *) + | InitIndexOld ((_, idx, _), ini) -> + Some (expr env idx), initialiser env ini + | InitDesignators([DesignatorIndex((_, idx, _))], _, ini) -> + Some (expr env idx), initialiser env ini + | x -> None, initialiser env x + )) + ) + + (* should be covered by caller *) + | InitDesignators _ -> debug (Init x); raise Todo + | InitIndexOld _ | InitFieldOld _ -> debug (Init x); raise Todo + +and storage _env x = + match x with + | NoSto -> A.DefaultStorage + | StoTypedef _ -> raise Impossible + | Sto (y, _) -> + (match y with + | Static -> A.Static + | Extern -> A.Extern + | Auto | Register -> A.DefaultStorage + ) + +(* ---------------------------------------------------------------------- *) +(* Cpp *) +(* ---------------------------------------------------------------------- *) + +and cpp_directive env x = + match x with + | Define (_tok, name, def_kind, def_val) -> + let v = cpp_def_val x env def_val in + (match def_kind with + | DefineVar -> + [A.Define (name, v)] + | DefineFunc(args) -> + [A.Macro(name, + args +> unparen +> uncomma +> List.map (fun (s, ii) -> + (s, List.hd ii) + ), + v)] + ) + | Include (tok, inc_kind, path) -> + let s = + match inc_kind with + | Local -> "\"" ^ path ^ "\"" + | Standard -> "<" ^ path ^ ">" + | Weird -> debug (Cpp x); raise Todo + in + [A.Include (s, tok)] + | Undef _ -> debug (Cpp x); raise Todo + | PragmaAndCo _ -> [] + +and cpp_def_val for_debug env x = + match x with + | DefineExpr e -> A.CppExpr (expr env e) + | DefineStmt st -> A.CppStmt (stmt env st) + | DefineDoWhileZero (st, _) -> A.CppStmt (stmt env st) + | DefinePrintWrapper (_, (_, e, _), id) -> + A.CppExpr ( + A.CondExpr (expr env e, + A.Id (name env id), + A.Id (name env id))) + + | DefineInit init -> A.CppExpr (initialiser env init) + + | DefineEmpty (* A.CppEmpty*) + | ( DefineText _| DefineFunction _ + | DefineType _ + | DefineTodo + ) -> + debug (Cpp for_debug); raise Todo + +(* ---------------------------------------------------------------------- *) +(* Stmt *) +(* ---------------------------------------------------------------------- *) + +and stmt env x = + let (st, ii) = x in + match st with + | Compound x -> A.Block (compound env x) + | Selection s -> + (match s with + | If (_, (_, e, _), st1, _, st2) -> + A.If (expr env e, stmt env st1, stmt env st2) + | Switch (_, (_, e, _), st) -> + A.Switch (expr env e, cases env st) + ) + | Iteration i -> + (match i with + | While (_, (_, e, _), st) -> + A.While (expr env e, stmt env st) + | DoWhile (_, st, _, (_, e, _), _) -> + A.DoWhile (stmt env st, expr env e) + | For (_, (_, ((est1, _), (est2, _), (est3, _)), _), st) -> + A.For ( + Common2.fmap (expr env) est1, + Common2.fmap (expr env) est2, + Common2.fmap (expr env) est3, + stmt env st + ) + + | MacroIteration _ -> + debug (Stmt x); raise Todo + ) + | ExprStatement eopt -> + (match eopt with + | None -> A.Block [] + | Some e -> A.ExprSt (expr env e) + ) + | DeclStmt block_decl -> + block_declaration env block_decl + + | Labeled lbl -> + (match lbl with + | Label (s, st) -> + A.Label ((s, List.hd ii), stmt env st) + | Case _ | CaseRange _ | Default _ -> + debug (Stmt x); raise CaseOutsideSwitch + ) + | Jump j -> + (match j with + | Goto s -> A.Goto ((s, List.hd ii)) + | Return -> A.Return None; + | ReturnExpr e -> A.Return (Some (expr env e)) + | Continue -> A.Continue + | Break -> A.Break + | GotoComputed _ -> debug (Stmt x); raise Todo + ) + + | Try (_, _, _) -> + debug (Stmt x); raise CplusplusConstruct + + | (NestedFunc _ | StmtTodo | MacroStmt ) -> + debug (Stmt x); raise Todo + +and compound env (_, xs, _) = + statements_sequencable env xs +> List.flatten + +and statements_sequencable env xs = + ifdef_skipper xs (function IfdefStmt x -> Some x | _ -> None) + +> List.map (statement_sequencable env) + + +and statement_sequencable env x = + match x with + | StmtElem st -> [stmt env st] + | CppDirectiveStmt x -> debug (Cpp x); raise Todo + | IfdefStmt _ -> raise Impossible + +and cases env x = + let (st, ii) = x in + match st with + | Compound (l, xs, r) -> + let rec aux xs = + match xs with + | [] -> [] + | x::xs -> + (match x with + | StmtElem ((Labeled (Case (_, st))), _) + | StmtElem ((Labeled (Default st)), _) + -> + let xs', rest = + (StmtElem st::xs) +> Common.span (function + | StmtElem ((Labeled (Case (_, _st))), _) + | StmtElem ((Labeled (Default _st)), _) -> false + | _ -> true + ) + in + let stmts = List.map (function + | StmtElem st -> stmt env st + | x -> + debug (Stmt (Compound (l, [x], r), ii)); + raise MacroInCase + ) xs' in + (match x with + | StmtElem ((Labeled (Case (e, _))), _) -> + A.Case (expr env e, stmts) + | StmtElem ((Labeled (Default _st)), _) -> + A.Default (stmts) + | _ -> raise Impossible + )::aux rest + | x -> debug (Body (l, [x], r)); raise Todo + ) + in + aux xs + | _ -> + debug (Stmt x); raise Todo + +and block_declaration env block_decl = + match block_decl with + | DeclList (xs, _) -> + let xs = uncomma xs in + A.Vars (Common.map_filter (onedecl env) xs) + + (* todo *) + | Asm (_tok1, _volatile_opt, _asmbody, _tok2) -> + A.Asm [] + + | MacroDecl _ -> debug (BlockDecl2 block_decl); raise Todo + + | UsingDecl _ | UsingDirective _ | NameSpaceAlias _ -> + raise CplusplusConstruct + + +(* ---------------------------------------------------------------------- *) +(* Expr *) +(* ---------------------------------------------------------------------- *) + +and expr env e = + let (e', toks) = e in + match e' with + | C cst -> constant env toks cst + + | Id (n, _) -> A.Id (name env n) + + | RecordAccess (e, n) -> + A.RecordPtAccess (A.Unary (expr env e, (GetRef,List.hd toks)), name env n) + | RecordPtAccess (e, n) -> + A.RecordPtAccess (expr env e, name env n) + + | Cast ((_, ft, _), e) -> + A.Cast (full_type env ft, expr env e) + + | ArrayAccess (e1, (_, e2, _)) -> + A.ArrayAccess (expr env e1, expr env e2) + | Binary (e1, op, e2) -> A.Binary (expr env e1, (op, List.hd toks), expr env e2) + | Unary (e, op) -> A.Unary (expr env e, (op, List.hd toks)) + | Infix (e, op) -> A.Infix (expr env e, (op, List.hd toks)) + | Postfix (e, op) -> A.Postfix (expr env e, (op, List.hd toks)) + + | Assignment (e1, op, e2) -> + A.Assign ((op, List.hd toks), expr env e1, expr env e2) + | Sequence (e1, e2) -> + A.Sequence (expr env e1, expr env e2) + | CondExpr (e1, e2opt, e3) -> + A.CondExpr (expr env e1, + (match e2opt with + | Some e2 -> expr env e2 + | None -> + debug (Expr e); raise Todo + ), + expr env e3) + | Call (e, args) -> + A.Call (expr env e, + Common.map_filter (argument env) (args +> unparen +> uncomma)) + + | SizeOfExpr (_tok, e) -> + A.SizeOf(Left (expr env e)) + | SizeOfType (_tok, (_, ft, _)) -> + A.SizeOf(Right (full_type env ft)) + | GccConstructor ((_, ft, _), xs) -> + A.GccConstructor (full_type env ft, + initialiser env (InitList xs)) + + | ConstructedObject (_, _) -> + pr2_once "BUG PARSING LOCAL DECL PROBABLY"; + debug (Expr e); + raise CplusplusConstruct + + | StatementExpr _ + | ExprTodo + -> + debug (Expr e); raise Todo + | Throw _|DeleteArray (_, _)|Delete (_, _)|New (_, _, _, _, _) + | CplusplusCast (_, _, _) + | This _ + | RecordPtStarAccess (_, _)|RecordStarAccess (_, _) + | TypeId (_, _) + -> + debug (Expr e); raise CplusplusConstruct + + | ParenExpr (_, e, _) -> expr env e + +and constant _env toks x = + match x with + | Int s -> A.Int (s, List.hd toks) + | Float (s, _) -> A.Float (s, List.hd toks) + | Char (s, _) -> A.Char (s, List.hd toks) + | String (s, _) -> A.String (s, List.hd toks) + + | Bool _ -> raise CplusplusConstruct + | MultiString -> A.String ("TODO", List.hd toks) + +and argument env x = + match x with + | Left e -> Some (expr env e) + (* TODO! can't just skip it ... *) + | Right _w -> + pr2 ("type argument, maybe wrong typedef inference!"); + debug (Argument x); + None + +(* ---------------------------------------------------------------------- *) +(* Type *) +(* ---------------------------------------------------------------------- *) +and full_type env x = + let (_qu, (t, ii)) = x in + match t with + | Pointer t -> A.TPointer (full_type env t) + | BaseType t -> + let s = + (match t with + | Void -> "void" + | FloatType ft -> + (match ft with + | CFloat -> "float" + | CDouble -> "double" + | CLongDouble -> "long_double" + ) + | IntType it -> + (match it with + | CChar -> "char" + | Si (si, base) -> + (match si with + | Signed -> "" + | UnSigned -> "unsigned_" + ) ^ + (match base with + (* 'char' is a CChar and 'unsigned char' is a Si (_, CChar2) *) + | CChar2 -> "char" + | CShort -> "short" + | CInt -> "int" + | CLong -> "long" + (* gccext: *) + | CLongLong -> "long_long" + ) + | CBool | WChar_t -> + debug (Type x); raise CplusplusConstruct + ) + ) + in + A.TBase (s, List.hd ii) + + | FunctionType ft -> A.TFunction (function_type env ft) + | Array ((_, eopt, _), ft) -> + A.TArray (Common.map_opt (expr env) eopt, full_type env ft) + | TypeName (n) -> A.TTypeName (name env n) + + | StructUnionName ((kind, _), name) -> + A.TStructName (struct_kind env kind, name) + | StructDef def -> + (match def with + { c_kind = (kind, tok); + c_name = name_opt; + c_inherit = _inh; + c_members = (_, xs, _); + } -> + let name = + match name_opt with + | None -> + incr cnt; + let s = spf "__anon_struct_%d" !cnt in + (s, tok) + | Some n -> name env n + in + let def' = { A. + s_name = name; + s_kind = struct_kind env kind; + s_flds = class_members_sequencable env xs +> List.flatten; + } + in + env.struct_defs_toadd <- def' :: env.struct_defs_toadd; + A.TStructName (struct_kind env kind, name) + ) + + | EnumName (_tok, name) -> A.TEnumName (name) + | EnumDef (tok, name_opt, xs) -> + let name = + match name_opt with + | None -> + incr cnt; + let s = spf "__anon_enum_%d" !cnt in + (s, tok) + | Some n -> n + in + let xs' = + xs +> unbrace +> uncomma +> List.map (fun eelem -> + let (name, e_opt) = eelem.e_name, eelem.e_val in + name, + match e_opt with + | None -> None + | Some (_tok, e) -> Some (expr env e) + ) + in + let def = name, xs' in + env.enum_defs_toadd <- def :: env.enum_defs_toadd; + A.TEnumName (name) + + | TypeOf (_, _) -> + debug (Type x); raise Todo + | TypenameKwd (_, _) | Reference _ -> + debug (Type x); raise CplusplusConstruct + + | ParenType (_, t, _) -> full_type env t + +(* ---------------------------------------------------------------------- *) +(* structure *) +(* ---------------------------------------------------------------------- *) +and class_member env x = + match x with + | MemberField (fldkind, _) -> + let xs = uncomma fldkind in + xs +> List.map (fieldkind env) + | ( UsingDeclInClass _| TemplateDeclInClass _ + | QualifiedIdInClass (_, _)| MemberDecl _| MemberFunc _| Access (_, _) + ) -> + debug (ClassMember x); raise Todo + | EmptyField _ -> [] + + +and class_members_sequencable env xs = + ifdef_skipper xs (function IfdefStruct x -> Some x | _ -> None) + +> List.map (class_member_sequencable env) + +and class_member_sequencable env x = + match x with + | ClassElem x -> class_member env x + | CppDirectiveStruct dir -> + debug (Cpp dir); raise Todo + | IfdefStruct _ -> raise Impossible + +and fieldkind env x = + match x with + | FieldDecl decl -> + (match decl with + { v_namei = ni; + v_type = ft; + v_storage = sto; + } -> + (match ni, sto with + | Some (n, None), NoSto -> + { A. + fld_name = Some (name env n); + fld_type = full_type env ft; + } + | None, NoSto -> + { A. + fld_name = None; + fld_type = full_type env ft; + } + + | _ -> debug (OneDecl decl); raise Todo + ) + ) + | BitField (name_opt, _tok, ft, e) -> + let _ = expr env e in + { A. + fld_name = name_opt; + fld_type = full_type env ft; + } + +(* ---------------------------------------------------------------------- *) +(* Misc *) +(* ---------------------------------------------------------------------- *) + +and name _env x = + match x with + | (None, [], IdIdent (name)) -> name + | _ -> debug (Name x); raise CplusplusConstruct + +and struct_kind _env = function + | Struct -> A.Struct + | Union -> A.Union + | Class -> raise CplusplusConstruct diff --git a/lang_c/parsing/ast_c_simple_build.mli b/lang_c/parsing/ast_c_simple_build.mli new file mode 100644 index 0000000..b1aa81a --- /dev/null +++ b/lang_c/parsing/ast_c_simple_build.mli @@ -0,0 +1,12 @@ + +exception ObsoleteConstruct of string * Parse_info.info +exception CplusplusConstruct +exception TodoConstruct of string * Parse_info.info +exception CaseOutsideSwitch +exception MacroInCase + +(* take care! this use Common.gensym to generate fresh unique anon structures + * so this function may return a different program given the same input + *) +val program: + Ast_cpp.program -> Ast_c.program diff --git a/lang_c/parsing/lib_parsing_c.ml b/lang_c/parsing/lib_parsing_c.ml new file mode 100644 index 0000000..7fc82f9 --- /dev/null +++ b/lang_c/parsing/lib_parsing_c.ml @@ -0,0 +1,49 @@ +(* Yoann Padioleau + * + * Copyright (C) 2012 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module FT = File_type +module V = Visitor_c + +(*****************************************************************************) +(* Filenames *) +(*****************************************************************************) + +let find_source_files_of_dir_or_files xs = + Common.files_of_dir_or_files_no_vcs_nofilter xs + +> List.filter (fun filename -> + match File_type.file_type_of_file filename with + | FT.PL (FT.C ("l" | "y")) -> false + | FT.PL (FT.C _) -> + (* todo: fix syncweb so don't need this! *) + not (FT.is_syncweb_obj_file filename) + | _ -> false + ) +> Common.sort + + +(*****************************************************************************) +(* ii_of_any *) +(*****************************************************************************) + +let ii_of_any any = + let globals = ref [] in + let visitor = V.mk_visitor { V.default_visitor with + V.kinfo = (fun (_k,_) i -> Common.push i globals) + } + in + visitor any; + List.rev !globals + + diff --git a/lang_c/parsing/lib_parsing_c.mli b/lang_c/parsing/lib_parsing_c.mli new file mode 100644 index 0000000..1c3b13b --- /dev/null +++ b/lang_c/parsing/lib_parsing_c.mli @@ -0,0 +1,6 @@ + +val find_source_files_of_dir_or_files: + Common.path list -> Common.filename list + +val ii_of_any: + Ast_c.any -> Parse_info.info list diff --git a/lang_c/parsing/meta_ast_c.ml b/lang_c/parsing/meta_ast_c.ml new file mode 100644 index 0000000..ffb7bee --- /dev/null +++ b/lang_c/parsing/meta_ast_c.ml @@ -0,0 +1,357 @@ + +(* generated by ocamltarzan with: camlp4o -o /tmp/yyy.ml -I pa/ pa_type_conv.cmo pa_vof.cmo pr_o.cmo /tmp/xxx.ml *) +open Ast_c + +let vof_info x = Parse_info.vof_info x +let vof_wrap _of_a (v1, v2) = + let v1 = _of_a v1 + and _v2TODO = vof_info v2 + in + Ocaml.VTuple [ v1 (* ; v2 *) ] + +and vof_unaryOp = + function + | Ast_cpp.GetRef -> Ocaml.VSum (("GetRef", [])) + | Ast_cpp.DeRef -> Ocaml.VSum (("DeRef", [])) + | Ast_cpp.UnPlus -> Ocaml.VSum (("UnPlus", [])) + | Ast_cpp.UnMinus -> Ocaml.VSum (("UnMinus", [])) + | Ast_cpp.Tilde -> Ocaml.VSum (("Tilde", [])) + | Ast_cpp.Not -> Ocaml.VSum (("Not", [])) + | Ast_cpp.GetRefLabel -> Ocaml.VSum (("GetRefLabel", [])) + +let rec vof_assignOp = + function + | Ast_cpp.SimpleAssign -> Ocaml.VSum (("SimpleAssign", [])) + | Ast_cpp.OpAssign v1 -> + let v1 = vof_arithOp v1 in Ocaml.VSum (("OpAssign", [ v1 ])) +and vof_fixOp = + function + | Ast_cpp.Dec -> Ocaml.VSum (("Dec", [])) + | Ast_cpp.Inc -> Ocaml.VSum (("Inc", [])) +and vof_binaryOp = + function + | Ast_cpp.Arith v1 -> let v1 = vof_arithOp v1 in Ocaml.VSum (("Arith", [ v1 ])) + | Ast_cpp.Logical v1 -> + let v1 = vof_logicalOp v1 in Ocaml.VSum (("Logical", [ v1 ])) +and vof_arithOp = + function + | Ast_cpp.Plus -> Ocaml.VSum (("Plus", [])) + | Ast_cpp.Minus -> Ocaml.VSum (("Minus", [])) + | Ast_cpp.Mul -> Ocaml.VSum (("Mul", [])) + | Ast_cpp.Div -> Ocaml.VSum (("Div", [])) + | Ast_cpp.Mod -> Ocaml.VSum (("Mod", [])) + | Ast_cpp.DecLeft -> Ocaml.VSum (("DecLeft", [])) + | Ast_cpp.DecRight -> Ocaml.VSum (("DecRight", [])) + | Ast_cpp.And -> Ocaml.VSum (("And", [])) + | Ast_cpp.Or -> Ocaml.VSum (("Or", [])) + | Ast_cpp.Xor -> Ocaml.VSum (("Xor", [])) +and vof_logicalOp = + function + | Ast_cpp.Inf -> Ocaml.VSum (("Inf", [])) + | Ast_cpp.Sup -> Ocaml.VSum (("Sup", [])) + | Ast_cpp.InfEq -> Ocaml.VSum (("InfEq", [])) + | Ast_cpp.SupEq -> Ocaml.VSum (("SupEq", [])) + | Ast_cpp.Eq -> Ocaml.VSum (("Eq", [])) + | Ast_cpp.NotEq -> Ocaml.VSum (("NotEq", [])) + | Ast_cpp.AndLog -> Ocaml.VSum (("AndLog", [])) + | Ast_cpp.OrLog -> Ocaml.VSum (("OrLog", [])) + + +let vof_name v = vof_wrap Ocaml.vof_string v + +let rec vof_type_ = + function + | TBase v1 -> let v1 = vof_name v1 in Ocaml.VSum (("TBase", [ v1 ])) + | TPointer v1 -> let v1 = vof_type_ v1 in Ocaml.VSum (("TPointer", [ v1 ])) + | TArray ((v1, v2)) -> + let v1 = Ocaml.vof_option vof_const_expr v1 + and v2 = vof_type_ v2 + in Ocaml.VSum (("TArray", [ v1; v2 ])) + | TFunction v1 -> + let v1 = vof_function_type v1 in Ocaml.VSum (("TFunction", [ v1 ])) + | TStructName ((v1, v2)) -> + let v1 = vof_struct_kind v1 + and v2 = vof_name v2 + in Ocaml.VSum (("TStructName", [ v1; v2 ])) + | TEnumName v1 -> + let v1 = vof_name v1 in Ocaml.VSum (("TEnumName", [ v1 ])) + | TTypeName v1 -> + let v1 = vof_name v1 in Ocaml.VSum (("TTypeName", [ v1 ])) +and vof_function_type (v1, v2) = + let v1 = vof_type_ v1 + and v2 = Ocaml.vof_list vof_parameter v2 + in Ocaml.VTuple [ v1; v2 ] +and vof_parameter { p_type = v_p_type; p_name = v_p_name } = + let bnds = [] in + let arg = Ocaml.vof_option vof_name v_p_name in + let bnd = ("p_name", arg) in + let bnds = bnd :: bnds in + let arg = vof_type_ v_p_type in + let bnd = ("p_type", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and vof_struct_kind = + function + | Struct -> Ocaml.VSum (("Struct", [])) + | Union -> Ocaml.VSum (("Union", [])) +and vof_const_expr v = vof_expr v + +and vof_expr = + function + | Int v1 -> + let v1 = vof_wrap Ocaml.vof_string v1 in Ocaml.VSum (("Int", [ v1 ])) + | Float v1 -> + let v1 = vof_wrap Ocaml.vof_string v1 in Ocaml.VSum (("Float", [ v1 ])) + | String v1 -> + let v1 = vof_wrap Ocaml.vof_string v1 + in Ocaml.VSum (("String", [ v1 ])) + | Char v1 -> + let v1 = vof_wrap Ocaml.vof_string v1 in Ocaml.VSum (("Char", [ v1 ])) + | Id v1 -> let v1 = vof_name v1 in Ocaml.VSum (("Id", [ v1 ])) + | Call ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = Ocaml.vof_list vof_expr v2 + in Ocaml.VSum (("Call", [ v1; v2 ])) + | Assign ((v1, v2, v3)) -> + let v1 = vof_wrap vof_assignOp v1 + and v2 = vof_expr v2 + and v3 = vof_expr v3 + in Ocaml.VSum (("Assign", [ v1; v2; v3 ])) + | ArrayAccess ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = vof_expr v2 + in Ocaml.VSum (("ArrayAccess", [ v1; v2 ])) + | RecordPtAccess ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = vof_name v2 + in Ocaml.VSum (("RecordPtAccess", [ v1; v2 ])) + | Cast ((v1, v2)) -> + let v1 = vof_type_ v1 + and v2 = vof_expr v2 + in Ocaml.VSum (("Cast", [ v1; v2 ])) + | Postfix ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = vof_wrap vof_fixOp v2 + in Ocaml.VSum (("Postfix", [ v1; v2 ])) + | Infix ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = vof_wrap vof_fixOp v2 + in Ocaml.VSum (("Infix", [ v1; v2 ])) + | Unary ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = vof_wrap vof_unaryOp v2 + in Ocaml.VSum (("Unary", [ v1; v2 ])) + | Binary ((v1, v2, v3)) -> + let v1 = vof_expr v1 + and v2 = vof_wrap vof_binaryOp v2 + and v3 = vof_expr v3 + in Ocaml.VSum (("Binary", [ v1; v2; v3 ])) + | CondExpr ((v1, v2, v3)) -> + let v1 = vof_expr v1 + and v2 = vof_expr v2 + and v3 = vof_expr v3 + in Ocaml.VSum (("CondExpr", [ v1; v2; v3 ])) + | Sequence ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = vof_expr v2 + in Ocaml.VSum (("Sequence", [ v1; v2 ])) + | SizeOf v1 -> + let v1 = Ocaml.vof_either vof_expr vof_type_ v1 + in Ocaml.VSum (("SizeOf", [ v1 ])) + | ArrayInit v1 -> + let v1 = + Ocaml.vof_list + (fun (v1, v2) -> + let v1 = Ocaml.vof_option vof_expr v1 + and v2 = vof_expr v2 + in Ocaml.VTuple [ v1; v2 ]) + v1 + in Ocaml.VSum (("ArrayInit", [ v1 ])) + | RecordInit v1 -> + let v1 = + Ocaml.vof_list + (fun (v1, v2) -> + let v1 = vof_name v1 + and v2 = vof_expr v2 + in Ocaml.VTuple [ v1; v2 ]) + v1 + in Ocaml.VSum (("RecordInit", [ v1 ])) + | GccConstructor ((v1, v2)) -> + let v1 = vof_type_ v1 + and v2 = vof_expr v2 + in Ocaml.VSum (("GccConstructor", [ v1; v2 ])) + +let rec vof_stmt = + function + | ExprSt v1 -> let v1 = vof_expr v1 in Ocaml.VSum (("ExprSt", [ v1 ])) + | Block v1 -> + let v1 = Ocaml.vof_list vof_stmt v1 in Ocaml.VSum (("Block", [ v1 ])) + | If ((v1, v2, v3)) -> + let v1 = vof_expr v1 + and v2 = vof_stmt v2 + and v3 = vof_stmt v3 + in Ocaml.VSum (("If", [ v1; v2; v3 ])) + | Switch ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = Ocaml.vof_list vof_case v2 + in Ocaml.VSum (("Switch", [ v1; v2 ])) + | While ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = vof_stmt v2 + in Ocaml.VSum (("While", [ v1; v2 ])) + | DoWhile ((v1, v2)) -> + let v1 = vof_stmt v1 + and v2 = vof_expr v2 + in Ocaml.VSum (("DoWhile", [ v1; v2 ])) + | For ((v1, v2, v3, v4)) -> + let v1 = Ocaml.vof_option vof_expr v1 + and v2 = Ocaml.vof_option vof_expr v2 + and v3 = Ocaml.vof_option vof_expr v3 + and v4 = vof_stmt v4 + in Ocaml.VSum (("For", [ v1; v2; v3; v4 ])) + | Return v1 -> + let v1 = Ocaml.vof_option vof_expr v1 + in Ocaml.VSum (("Return", [ v1 ])) + | Continue -> Ocaml.VSum (("Continue", [])) + | Break -> Ocaml.VSum (("Break", [])) + | Label ((v1, v2)) -> + let v1 = vof_name v1 + and v2 = vof_stmt v2 + in Ocaml.VSum (("Label", [ v1; v2 ])) + | Goto v1 -> let v1 = vof_name v1 in Ocaml.VSum (("Goto", [ v1 ])) + | Vars v1 -> + let v1 = Ocaml.vof_list vof_var_decl v1 + in Ocaml.VSum (("Vars", [ v1 ])) + | Asm v1 -> + let v1 = Ocaml.vof_list vof_expr v1 in Ocaml.VSum (("Asm", [ v1 ])) +and vof_case = + function + | Case ((v1, v2)) -> + let v1 = vof_expr v1 + and v2 = Ocaml.vof_list vof_stmt v2 + in Ocaml.VSum (("Case", [ v1; v2 ])) + | Default v1 -> + let v1 = Ocaml.vof_list vof_stmt v1 in Ocaml.VSum (("Default", [ v1 ])) +and + vof_var_decl { + v_name = v_v_name; + v_type = v_v_type; + v_storage = v_v_storage; + v_init = v_v_init + } = + let bnds = [] in + let arg = Ocaml.vof_option vof_initialiser v_v_init in + let bnd = ("v_init", arg) in + let bnds = bnd :: bnds in + let arg = vof_storage v_v_storage in + let bnd = ("v_storage", arg) in + let bnds = bnd :: bnds in + let arg = vof_type_ v_v_type in + let bnd = ("v_type", arg) in + let bnds = bnd :: bnds in + let arg = vof_name v_v_name in + let bnd = ("v_name", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and vof_initialiser v = vof_expr v +and vof_storage = + function + | Extern -> Ocaml.VSum (("Extern", [])) + | Static -> Ocaml.VSum (("Static", [])) + | DefaultStorage -> Ocaml.VSum (("DefaultStorage", [])) + +let vof_func_def + { f_name = v_f_name; f_type = v_f_type; f_body = v_f_body; + f_static = v_f_static } + = + let bnds = [] in + let arg = Ocaml.vof_list vof_stmt v_f_body in + let bnd = ("f_body", arg) in + let bnds = bnd :: bnds in + let arg = vof_function_type v_f_type in + let bnd = ("f_type", arg) in + let bnds = bnd :: bnds in + let arg = vof_name v_f_name in + let bnd = ("f_name", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_bool v_f_static in + let bnd = ("f_static", arg) in + let bnds = bnd :: bnds in + Ocaml.VDict bnds + +and vof_field_def { fld_name = v_fld_name; fld_type = v_fld_type } = + let bnds = [] in + let arg = vof_type_ v_fld_type in + let bnd = ("fld_type", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_option vof_name v_fld_name in + let bnd = ("fld_name", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds + +let vof_enum_def (v1, v2) = + let v1 = vof_name v1 + and v2 = + Ocaml.vof_list + (fun (v1, v2) -> + let v1 = vof_name v1 + and v2 = Ocaml.vof_option vof_expr v2 + in Ocaml.VTuple [ v1; v2 ]) + v2 + in Ocaml.VTuple [ v1; v2 ] + +let vof_type_def (v1, v2) = + let v1 = vof_name v1 and v2 = vof_type_ v2 in Ocaml.VTuple [ v1; v2 ] + +let vof_define_body = + function + | CppExpr v1 -> let v1 = vof_expr v1 in Ocaml.VSum (("CppExpr", [ v1 ])) + | CppStmt v1 -> let v1 = vof_stmt v1 in Ocaml.VSum (("CppStmt", [ v1 ])) +(* | CppEmpty -> Ocaml.VSum (("CppEmpty", [])) *) + +let + vof_struct_def { s_name = v_s_name; s_kind = v_s_kind; s_flds = v_s_flds } + = + let bnds = [] in + let arg = Ocaml.vof_list vof_field_def v_s_flds in + let bnd = ("s_flds", arg) in + let bnds = bnd :: bnds in + let arg = vof_struct_kind v_s_kind in + let bnd = ("s_kind", arg) in + let bnds = bnd :: bnds in + let arg = vof_name v_s_name in + let bnd = ("s_name", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds + + +let vof_toplevel = + function + | Define ((v1, v2)) -> + let v1 = vof_name v1 + and v2 = vof_define_body v2 + in Ocaml.VSum (("Define", [ v1; v2 ])) +(* | Undef v1 -> let v1 = vof_name v1 in Ocaml.VSum (("Undef", [ v1 ])) *) + | Include v1 -> + let v1 = vof_wrap Ocaml.vof_string v1 + in Ocaml.VSum (("Include", [ v1 ])) + | Macro ((v1, v2, v3)) -> + let v1 = vof_name v1 + and v2 = Ocaml.vof_list vof_name v2 + and v3 = vof_define_body v3 + in Ocaml.VSum (("Macro", [ v1; v2; v3 ])) + | StructDef v1 -> + let v1 = vof_struct_def v1 in Ocaml.VSum (("StructDef", [ v1 ])) + | TypeDef v1 -> + let v1 = vof_type_def v1 in Ocaml.VSum (("TypeDef", [ v1 ])) + | EnumDef v1 -> + let v1 = vof_enum_def v1 in Ocaml.VSum (("EnumDef", [ v1 ])) + | FuncDef v1 -> + let v1 = vof_func_def v1 in Ocaml.VSum (("FuncDef", [ v1 ])) + | Global v1 -> let v1 = vof_var_decl v1 in Ocaml.VSum (("Global", [ v1 ])) + | Prototype v1 -> + let v1 = vof_func_def v1 in Ocaml.VSum (("Prototype", [ v1 ])) + +let vof_program v = Ocaml.vof_list vof_toplevel v + +let vof_any = + function + | Expr v1 -> let v1 = vof_expr v1 in Ocaml.VSum (("Expr", [ v1 ])) + | Stmt v1 -> let v1 = vof_stmt v1 in Ocaml.VSum (("Stmt", [ v1 ])) + | Type v1 -> let v1 = vof_type_ v1 in Ocaml.VSum (("Type", [ v1 ])) + | Toplevel v1 -> + let v1 = vof_toplevel v1 in Ocaml.VSum (("Toplevel", [ v1 ])) + | Program v1 -> let v1 = vof_program v1 in Ocaml.VSum (("Program", [ v1 ])) + diff --git a/lang_c/parsing/meta_ast_c.mli b/lang_c/parsing/meta_ast_c.mli new file mode 100644 index 0000000..e4a8af7 --- /dev/null +++ b/lang_c/parsing/meta_ast_c.mli @@ -0,0 +1,7 @@ + +val vof_program: Ast_c.program -> Ocaml.v +val vof_any: Ast_c.any -> Ocaml.v + +(* used by meta_ast_cil.ml *) +val vof_type_: Ast_c.type_ -> Ocaml.v + diff --git a/lang_c/parsing/parse_c.ml b/lang_c/parsing/parse_c.ml new file mode 100644 index 0000000..dc3a3f9 --- /dev/null +++ b/lang_c/parsing/parse_c.ml @@ -0,0 +1,51 @@ +(* Yoann Padioleau + * + * Copyright (C) 2012 Yoann Padioleau + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module Stat = Parse_info + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * Just a small wrapper around the C++ parser + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type program_and_tokens = + Ast_c.program option * Parser_cpp.token list + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +let parse file = + let (ast2, stat) = Parse_cpp.parse_with_lang ~lang:Flag_parsing_cpp.C file in + let ast = ast2 +> List.map fst in + let toks = ast2 +> List.map snd +> List.flatten in + let ast_opt, stat = + try Some (Ast_c_simple_build.program ast), stat + with exn -> + pr2 (spf "PB: Ast_c_build, on %s (exn = %s)" file (Common.exn_to_s exn)); + (*None, { stat with Stat.bad = stat.Stat.bad + stat.Stat.correct } *) + raise exn + in + (ast_opt, toks), stat + +let parse_program file = + let (program_and_tokens, _stat) = parse file in + Common2.some (fst program_and_tokens) diff --git a/lang_c/parsing/parse_c.mli b/lang_c/parsing/parse_c.mli new file mode 100644 index 0000000..833bddd --- /dev/null +++ b/lang_c/parsing/parse_c.mli @@ -0,0 +1,13 @@ + +(* the token list contains also the comment-tokens *) +type program_and_tokens = + Ast_c.program option * Parser_cpp.token list + +(* take care! this use Common.gensym to generate fresh unique anon structures + * so this function may return a different program given the same input + *) +val parse: + Common.filename -> (program_and_tokens * Parse_info.parsing_stat) + +val parse_program: + Common.filename -> Ast_c.program diff --git a/lang_c/parsing/test_parsing_c.ml b/lang_c/parsing/test_parsing_c.ml new file mode 100644 index 0000000..6bd3096 --- /dev/null +++ b/lang_c/parsing/test_parsing_c.ml @@ -0,0 +1,39 @@ +open Common + +module Stat = Parse_info +(*****************************************************************************) +(* Subsystem testing *) +(*****************************************************************************) + +let test_parse_c xs = + let fullxs = Lib_parsing_c.find_source_files_of_dir_or_files xs in + let stat_list = ref [] in + + fullxs +> (*Console.progress (fun k -> *) List.iter ((fun file -> + (*k(); *) + pr (spf "PARSING: %s" file); + let (_xs, stat) = + Parse_c.parse file + in + Common.push stat stat_list; + )); + Stat.print_recurring_problematic_tokens !stat_list; + Stat.print_parsing_stat_list !stat_list; + () + +let test_dump_c file = + let ast = Parse_c.parse_program file in + let v = Meta_ast_c.vof_program ast in + let s = Ocaml.string_of_v v in + pr s + +(*****************************************************************************) +(* Main entry for Arg *) +(*****************************************************************************) + +let actions () = [ + "-parse_c", " ", + Common.mk_action_n_arg test_parse_c; + "-dump_c", " ", + Common.mk_action_1_arg test_dump_c; +] diff --git a/lang_c/parsing/test_parsing_c.mli b/lang_c/parsing/test_parsing_c.mli new file mode 100644 index 0000000..726db48 --- /dev/null +++ b/lang_c/parsing/test_parsing_c.mli @@ -0,0 +1,3 @@ + +val actions: unit -> Common.cmdline_actions + diff --git a/lang_c/parsing/unit_parsing_c.ml b/lang_c/parsing/unit_parsing_c.ml new file mode 100644 index 0000000..e69de29 diff --git a/lang_c/parsing/unit_parsing_c.mli b/lang_c/parsing/unit_parsing_c.mli new file mode 100644 index 0000000..e69de29 diff --git a/lang_c/parsing/visitor_c.ml b/lang_c/parsing/visitor_c.ml new file mode 100644 index 0000000..1a65286 --- /dev/null +++ b/lang_c/parsing/visitor_c.ml @@ -0,0 +1,227 @@ +(* Yoann Padioleau + * + * Copyright (C) 2014 Facebook + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) + +open Ocaml +open Ast_c + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* hooks *) +type visitor_in = { + kexpr: Ast_c.expr vin; + kinfo: Ast_cpp.tok vin; +} +and visitor_out = any -> unit +and 'a vin = ('a -> unit) * visitor_out -> 'a -> unit + +module Ast_cpp = struct + let v_assignOp _ = () + let v_fixOp _ = () + let v_unaryOp _ = () + let v_binaryOp _ = () +end + +let default_visitor = { + kinfo = (fun (k,_) x -> k x); + kexpr = (fun (k,_) x -> k x); +} + +let (mk_visitor: visitor_in -> visitor_out) = fun vin -> + +let rec v_info x = + let k _ = () in + vin.kinfo (k, all_functions) x + +and v_wrap:'a. ('a -> unit) -> 'a wrap -> unit = + fun _of_a (v1, v2) -> + let v1 = _of_a v1 and v2 = v_info v2 in () + +and v_name v = v_wrap v_string v + +and v_type_ = + function + | TBase v1 -> let v1 = v_name v1 in () + | TPointer v1 -> let v1 = v_type_ v1 in () + | TArray ((v1, v2)) -> + let v1 = v_option v_const_expr v1 and v2 = v_type_ v2 in () + | TFunction v1 -> let v1 = v_function_type v1 in () + | TStructName ((v1, v2)) -> + let v1 = v_struct_kind v1 and v2 = v_name v2 in () + | TEnumName v1 -> let v1 = v_name v1 in () + | TTypeName v1 -> let v1 = v_name v1 in () + +and v_function_type (v1, v2) = + let v1 = v_type_ v1 and v2 = v_list v_parameter v2 in () +and v_parameter { p_type = v_p_type; p_name = v_p_name } = + let arg = v_type_ v_p_type in let arg = v_option v_name v_p_name in () +and v_struct_kind = function | Struct -> () | Union -> () +and v_const_expr v = v_expr v +and v_expr x = + let k x = match x with + | Int v1 -> let v1 = v_wrap v_string v1 in () + | Float v1 -> let v1 = v_wrap v_string v1 in () + | String v1 -> let v1 = v_wrap v_string v1 in () + | Char v1 -> let v1 = v_wrap v_string v1 in () + | Id v1 -> let v1 = v_name v1 in () + | Call ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_list v_argument v2 in () + | Assign ((v1, v2, v3)) -> + let v1 = v_wrap Ast_cpp.v_assignOp v1 + and v2 = v_expr v2 + and v3 = v_expr v3 + in () + | ArrayAccess ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_expr v2 in () + | RecordPtAccess ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_name v2 in () + | Cast ((v1, v2)) -> let v1 = v_type_ v1 and v2 = v_expr v2 in () + | Postfix ((v1, v2)) -> + let v1 = v_expr v1 and v2 = v_wrap Ast_cpp.v_fixOp v2 in () + | Infix ((v1, v2)) -> + let v1 = v_expr v1 and v2 = v_wrap Ast_cpp.v_fixOp v2 in () + | Unary ((v1, v2)) -> + let v1 = v_expr v1 and v2 = v_wrap Ast_cpp.v_unaryOp v2 in () + | Binary ((v1, v2, v3)) -> + let v1 = v_expr v1 + and v2 = v_wrap Ast_cpp.v_binaryOp v2 + and v3 = v_expr v3 + in () + | CondExpr ((v1, v2, v3)) -> + let v1 = v_expr v1 and v2 = v_expr v2 and v3 = v_expr v3 in () + | Sequence ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_expr v2 in () + | SizeOf v1 -> let v1 = Ocaml.v_either v_expr v_type_ v1 in () + | ArrayInit v1 -> + let v1 = + v_list + (fun (v1, v2) -> + let v1 = v_option v_expr v1 and v2 = v_expr v2 in ()) + v1 + in () + | RecordInit v1 -> + let v1 = + v_list (fun (v1, v2) -> let v1 = v_name v1 and v2 = v_expr v2 in ()) + v1 + in () + | GccConstructor ((v1, v2)) -> let v1 = v_type_ v1 and v2 = v_expr v2 in () + in + vin.kexpr (k, all_functions) x +and v_argument v = v_expr v + +and v_stmt = + function + | ExprSt v1 -> let v1 = v_expr v1 in () + | Block v1 -> let v1 = v_list v_stmt v1 in () + | If ((v1, v2, v3)) -> + let v1 = v_expr v1 and v2 = v_stmt v2 and v3 = v_stmt v3 in () + | Switch ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_list v_case v2 in () + | While ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_stmt v2 in () + | DoWhile ((v1, v2)) -> let v1 = v_stmt v1 and v2 = v_expr v2 in () + | For ((v1, v2, v3, v4)) -> + let v1 = v_option v_expr v1 + and v2 = v_option v_expr v2 + and v3 = v_option v_expr v3 + and v4 = v_stmt v4 + in () + | Return v1 -> let v1 = v_option v_expr v1 in () + | Continue -> () + | Break -> () + | Label ((v1, v2)) -> let v1 = v_name v1 and v2 = v_stmt v2 in () + | Goto v1 -> let v1 = v_name v1 in () + | Vars v1 -> let v1 = v_list v_var_decl v1 in () + | Asm v1 -> let v1 = v_list v_expr v1 in () + +and v_case = + function + | Case ((v1, v2)) -> let v1 = v_expr v1 and v2 = v_list v_stmt v2 in () + | Default v1 -> let v1 = v_list v_stmt v1 in () +and + v_var_decl { + v_name = v_v_name; + v_type = v_v_type; + v_storage = v_v_storage; + v_init = v_v_init + } = + let arg = v_name v_v_name in + let arg = v_type_ v_v_type in + let arg = v_storage v_v_storage in + let arg = v_option v_initialiser v_v_init in () +and v_initialiser v = v_expr v +and v_storage = function | Extern -> () | Static -> () | DefaultStorage -> () + +and v_struct_def { s_name = v_s_name; s_kind = v_s_kind; s_flds = v_s_flds } = + let arg = v_name v_s_name in + let arg = v_struct_kind v_s_kind in + let arg = v_list v_field_def v_s_flds in () + +and v_field_def { fld_name = v_fld_name; fld_type = v_fld_type } = + let arg = v_option v_name v_fld_name in let arg = v_type_ v_fld_type in () + +and v_func_def { + f_name = v_f_name; + f_type = v_f_type; + f_body = v_f_body; + f_static = v_f_static + } = + let arg = v_name v_f_name in + let arg = v_function_type v_f_type in + let arg = v_list v_stmt v_f_body in let arg = v_bool v_f_static in () + +and v_define_body = + function + | CppExpr v1 -> let v1 = v_expr v1 in () + | CppStmt v1 -> let v1 = v_stmt v1 in () + +and v_toplevel = + function + | Include v1 -> let v1 = v_wrap v_string v1 in () + | Define ((v1, v2)) -> let v1 = v_name v1 and v2 = v_define_body v2 in () + | Macro ((v1, v2, v3)) -> + let v1 = v_name v1 + and v2 = v_list v_name v2 + and v3 = v_define_body v3 + in () + | StructDef v1 -> let v1 = v_struct_def v1 in () + | TypeDef v1 -> let v1 = v_type_def v1 in () + | EnumDef v1 -> let v1 = v_enum_def v1 in () + | FuncDef v1 -> let v1 = v_func_def v1 in () + | Global v1 -> let v1 = v_var_decl v1 in () + | Prototype v1 -> let v1 = v_func_def v1 in () + +and v_type_def (v1, v2) = let v1 = v_name v1 and v2 = v_type_ v2 in () + +and v_enum_def (v1, v2) = + let v1 = v_name v1 + and v2 = + v_list + (fun (v1, v2) -> let v1 = v_name v1 and v2 = v_option v_expr v2 in ()) + v2 + in () + +and v_any = + function + | Expr v1 -> let v1 = v_expr v1 in () + | Stmt v1 -> let v1 = v_stmt v1 in () + | Type v1 -> let v1 = v_type_ v1 in () + | Toplevel v1 -> let v1 = v_toplevel v1 in () + | Program v1 -> let v1 = v_program v1 in () + +and v_program v = v_list v_toplevel v + + and all_functions x = v_any x +in + v_any + diff --git a/lang_cpp/parsing/.depend b/lang_cpp/parsing/.depend new file mode 100644 index 0000000..0e1c43d --- /dev/null +++ b/lang_cpp/parsing/.depend @@ -0,0 +1,202 @@ +ast_cpp.cmo : ../../h_program-lang/scope_code.cmi \ + ../../h_program-lang/parse_info.cmi ../../commons/common.cmi +ast_cpp.cmx : ../../h_program-lang/scope_code.cmx \ + ../../h_program-lang/parse_info.cmx ../../commons/common.cmx +flag_parsing_cpp.cmo : ../../globals/config_pfff.cmo +flag_parsing_cpp.cmx : ../../globals/config_pfff.cmx +lexer_cpp.cmo : parser_cpp.cmi ../../h_program-lang/parse_info.cmi \ + flag_parsing_cpp.cmo ../../commons/common2.cmi ../../commons/common.cmi \ + ast_cpp.cmo +lexer_cpp.cmx : parser_cpp.cmx ../../h_program-lang/parse_info.cmx \ + flag_parsing_cpp.cmx ../../commons/common2.cmx ../../commons/common.cmx \ + ast_cpp.cmx +lib_parsing_cpp.cmo : visitor_cpp.cmi ../../commons/file_type.cmi \ + ../../commons/common.cmi lib_parsing_cpp.cmi +lib_parsing_cpp.cmx : visitor_cpp.cmx ../../commons/file_type.cmx \ + ../../commons/common.cmx lib_parsing_cpp.cmi +lib_parsing_cpp.cmi : ../../h_program-lang/parse_info.cmi \ + ../../commons/common.cmi ast_cpp.cmo +meta_ast_cpp.cmo : ../../h_program-lang/scope_code.cmi \ + ../../h_program-lang/parse_info.cmi ../../commons/ocaml.cmi \ + ../../h_program-lang/meta_ast_generic.cmi ../../commons/common.cmi \ + ast_cpp.cmo meta_ast_cpp.cmi +meta_ast_cpp.cmx : ../../h_program-lang/scope_code.cmx \ + ../../h_program-lang/parse_info.cmx ../../commons/ocaml.cmx \ + ../../h_program-lang/meta_ast_generic.cmx ../../commons/common.cmx \ + ast_cpp.cmx meta_ast_cpp.cmi +meta_ast_cpp.cmi : ../../commons/ocaml.cmi \ + ../../h_program-lang/meta_ast_generic.cmi ast_cpp.cmo +parse_cpp.cmo : token_views_cpp.cmi token_helpers_cpp.cmi token_cpp.cmi \ + pp_token.cmi parsing_recovery_cpp.cmi parsing_hacks_lib.cmi \ + parsing_hacks_define.cmi parsing_hacks_cpp.cmi parsing_hacks.cmi \ + parser_cpp_mly_helper.cmo parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi lexer_cpp.cmo flag_parsing_cpp.cmo \ + ../../commons/file_type.cmi ../../commons/common2.cmi \ + ../../commons/common.cmi ../../h_program-lang/ast_fuzzy.cmi ast_cpp.cmo \ + parse_cpp.cmi +parse_cpp.cmx : token_views_cpp.cmx token_helpers_cpp.cmx token_cpp.cmx \ + pp_token.cmx parsing_recovery_cpp.cmx parsing_hacks_lib.cmx \ + parsing_hacks_define.cmx parsing_hacks_cpp.cmx parsing_hacks.cmx \ + parser_cpp_mly_helper.cmx parser_cpp.cmx \ + ../../h_program-lang/parse_info.cmx lexer_cpp.cmx flag_parsing_cpp.cmx \ + ../../commons/file_type.cmx ../../commons/common2.cmx \ + ../../commons/common.cmx ../../h_program-lang/ast_fuzzy.cmx ast_cpp.cmx \ + parse_cpp.cmi +parse_cpp.cmi : pp_token.cmi parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi flag_parsing_cpp.cmo \ + ../../commons/common.cmi ../../h_program-lang/ast_fuzzy.cmi ast_cpp.cmo +parser_cpp.cmo : token_cpp.cmi parser_cpp_mly_helper.cmo \ + ../../h_program-lang/parse_info.cmi ../../commons/common.cmi ast_cpp.cmo \ + parser_cpp.cmi +parser_cpp.cmx : token_cpp.cmx parser_cpp_mly_helper.cmx \ + ../../h_program-lang/parse_info.cmx ../../commons/common.cmx ast_cpp.cmx \ + parser_cpp.cmi +parser_cpp.cmi : token_cpp.cmi ../../h_program-lang/parse_info.cmi \ + ast_cpp.cmo +parser_cpp_mly_helper.cmo : lib_parsing_cpp.cmi flag_parsing_cpp.cmo \ + ../../commons/common2.cmi ../../commons/common.cmi ast_cpp.cmo +parser_cpp_mly_helper.cmx : lib_parsing_cpp.cmx flag_parsing_cpp.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx ast_cpp.cmx +parsing_hacks.cmo : token_views_cpp.cmi token_views_context.cmi \ + token_helpers_cpp.cmi pp_token.cmi parsing_hacks_typedef.cmi \ + parsing_hacks_pp.cmi parsing_hacks_define.cmi parsing_hacks_cpp.cmi \ + parser_cpp.cmi ../../h_program-lang/parse_info.cmi flag_parsing_cpp.cmo \ + ../../commons/common2.cmi ../../commons/common.cmi ast_cpp.cmo \ + parsing_hacks.cmi +parsing_hacks.cmx : token_views_cpp.cmx token_views_context.cmx \ + token_helpers_cpp.cmx pp_token.cmx parsing_hacks_typedef.cmx \ + parsing_hacks_pp.cmx parsing_hacks_define.cmx parsing_hacks_cpp.cmx \ + parser_cpp.cmx ../../h_program-lang/parse_info.cmx flag_parsing_cpp.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx ast_cpp.cmx \ + parsing_hacks.cmi +parsing_hacks.cmi : pp_token.cmi parser_cpp.cmi flag_parsing_cpp.cmo +parsing_hacks_cpp.cmo : token_views_cpp.cmi token_helpers_cpp.cmi \ + token_cpp.cmi parsing_hacks_lib.cmi parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi flag_parsing_cpp.cmo \ + ../../commons/common.cmi ast_cpp.cmo parsing_hacks_cpp.cmi +parsing_hacks_cpp.cmx : token_views_cpp.cmx token_helpers_cpp.cmx \ + token_cpp.cmx parsing_hacks_lib.cmx parser_cpp.cmx \ + ../../h_program-lang/parse_info.cmx flag_parsing_cpp.cmx \ + ../../commons/common.cmx ast_cpp.cmx parsing_hacks_cpp.cmi +parsing_hacks_cpp.cmi : token_views_cpp.cmi +parsing_hacks_define.cmo : token_helpers_cpp.cmi parsing_hacks_lib.cmi \ + parser_cpp.cmi ../../h_program-lang/parse_info.cmi flag_parsing_cpp.cmo \ + ../../commons/common2.cmi ../../commons/common.cmi ast_cpp.cmo \ + parsing_hacks_define.cmi +parsing_hacks_define.cmx : token_helpers_cpp.cmx parsing_hacks_lib.cmx \ + parser_cpp.cmx ../../h_program-lang/parse_info.cmx flag_parsing_cpp.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx ast_cpp.cmx \ + parsing_hacks_define.cmi +parsing_hacks_define.cmi : parser_cpp.cmi +parsing_hacks_lib.cmo : token_views_cpp.cmi token_helpers_cpp.cmi \ + token_cpp.cmi parser_cpp.cmi ../../h_program-lang/parse_info.cmi \ + flag_parsing_cpp.cmo ../../commons/common2.cmi ../../commons/common.cmi \ + ast_cpp.cmo parsing_hacks_lib.cmi +parsing_hacks_lib.cmx : token_views_cpp.cmx token_helpers_cpp.cmx \ + token_cpp.cmx parser_cpp.cmx ../../h_program-lang/parse_info.cmx \ + flag_parsing_cpp.cmx ../../commons/common2.cmx ../../commons/common.cmx \ + ast_cpp.cmx parsing_hacks_lib.cmi +parsing_hacks_lib.cmi : token_views_cpp.cmi token_cpp.cmi parser_cpp.cmi +parsing_hacks_pp.cmo : token_views_cpp.cmi token_helpers_cpp.cmi \ + token_cpp.cmi parsing_hacks_lib.cmi parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi flag_parsing_cpp.cmo \ + ../../commons/common2.cmi ../../commons/common.cmi ast_cpp.cmo \ + parsing_hacks_pp.cmi +parsing_hacks_pp.cmx : token_views_cpp.cmx token_helpers_cpp.cmx \ + token_cpp.cmx parsing_hacks_lib.cmx parser_cpp.cmx \ + ../../h_program-lang/parse_info.cmx flag_parsing_cpp.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx ast_cpp.cmx \ + parsing_hacks_pp.cmi +parsing_hacks_pp.cmi : token_views_cpp.cmi +parsing_hacks_typedef.cmo : token_views_cpp.cmi token_views_context.cmi \ + token_helpers_cpp.cmi parsing_hacks_lib.cmi parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi ../../commons/common.cmi ast_cpp.cmo \ + parsing_hacks_typedef.cmi +parsing_hacks_typedef.cmx : token_views_cpp.cmx token_views_context.cmx \ + token_helpers_cpp.cmx parsing_hacks_lib.cmx parser_cpp.cmx \ + ../../h_program-lang/parse_info.cmx ../../commons/common.cmx ast_cpp.cmx \ + parsing_hacks_typedef.cmi +parsing_hacks_typedef.cmi : token_views_cpp.cmi +parsing_recovery_cpp.cmo : token_helpers_cpp.cmi parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi flag_parsing_cpp.cmo \ + ../../commons/common2.cmi ../../commons/common.cmi \ + parsing_recovery_cpp.cmi +parsing_recovery_cpp.cmx : token_helpers_cpp.cmx parser_cpp.cmx \ + ../../h_program-lang/parse_info.cmx flag_parsing_cpp.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx \ + parsing_recovery_cpp.cmi +parsing_recovery_cpp.cmi : parser_cpp.cmi +pp_token.cmo : token_views_cpp.cmi token_helpers_cpp.cmi token_cpp.cmi \ + parsing_hacks_lib.cmi parser_cpp.cmi flag_parsing_cpp.cmo \ + ../../commons/common2.cmi ../../commons/common.cmi ast_cpp.cmo \ + pp_token.cmi +pp_token.cmx : token_views_cpp.cmx token_helpers_cpp.cmx token_cpp.cmx \ + parsing_hacks_lib.cmx parser_cpp.cmx flag_parsing_cpp.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx ast_cpp.cmx \ + pp_token.cmi +pp_token.cmi : token_views_cpp.cmi parser_cpp.cmi ../../commons/common.cmi +test_dump_nim.cmo : ../../h_program-lang/parse_info.cmi parse_cpp.cmi \ + flag_parsing_cpp.cmo ../../commons/common.cmi ast_cpp.cmo \ + test_dump_nim.cmi +test_dump_nim.cmx : ../../h_program-lang/parse_info.cmx parse_cpp.cmx \ + flag_parsing_cpp.cmx ../../commons/common.cmx ast_cpp.cmx \ + test_dump_nim.cmi +test_dump_nim.cmi : ../../commons/common.cmi +test_parsing_cpp.cmo : token_views_cpp.cmi token_views_context.cmi \ + token_helpers_cpp.cmi test_dump_nim.cmi \ + ../../h_program-lang/skip_code.cmi parsing_hacks_cpp.cmi parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi parse_cpp.cmi ../../commons/ocaml.cmi \ + ../../h_program-lang/meta_ast_generic.cmi meta_ast_cpp.cmi \ + lib_parsing_cpp.cmi flag_parsing_cpp.cmo ../../commons_core/console.cmi \ + ../../commons/common.cmi ../../h_program-lang/ast_fuzzy.cmi ast_cpp.cmo \ + test_parsing_cpp.cmi +test_parsing_cpp.cmx : token_views_cpp.cmx token_views_context.cmx \ + token_helpers_cpp.cmx test_dump_nim.cmx \ + ../../h_program-lang/skip_code.cmx parsing_hacks_cpp.cmx parser_cpp.cmx \ + ../../h_program-lang/parse_info.cmx parse_cpp.cmx ../../commons/ocaml.cmx \ + ../../h_program-lang/meta_ast_generic.cmx meta_ast_cpp.cmx \ + lib_parsing_cpp.cmx flag_parsing_cpp.cmx ../../commons_core/console.cmx \ + ../../commons/common.cmx ../../h_program-lang/ast_fuzzy.cmx ast_cpp.cmx \ + test_parsing_cpp.cmi +test_parsing_cpp.cmi : ../../commons/common.cmi +token_cpp.cmo : token_cpp.cmi +token_cpp.cmx : token_cpp.cmi +token_cpp.cmi : +token_helpers_cpp.cmo : parser_cpp.cmi ../../h_program-lang/parse_info.cmi \ + token_helpers_cpp.cmi +token_helpers_cpp.cmx : parser_cpp.cmx ../../h_program-lang/parse_info.cmx \ + token_helpers_cpp.cmi +token_helpers_cpp.cmi : parser_cpp.cmi ../../h_program-lang/parse_info.cmi +token_views_context.cmo : token_views_cpp.cmi token_helpers_cpp.cmi \ + parser_cpp.cmi ../../h_program-lang/parse_info.cmi \ + ../../commons/common2.cmi ../../commons/common.cmi \ + token_views_context.cmi +token_views_context.cmx : token_views_cpp.cmx token_helpers_cpp.cmx \ + parser_cpp.cmx ../../h_program-lang/parse_info.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx \ + token_views_context.cmi +token_views_context.cmi : token_views_cpp.cmi +token_views_cpp.cmo : token_helpers_cpp.cmi parser_cpp.cmi \ + ../../h_program-lang/parse_info.cmi ../../commons/ocaml.cmi \ + flag_parsing_cpp.cmo ../../commons/common2.cmi ../../commons/common.cmi \ + token_views_cpp.cmi +token_views_cpp.cmx : token_helpers_cpp.cmx parser_cpp.cmx \ + ../../h_program-lang/parse_info.cmx ../../commons/ocaml.cmx \ + flag_parsing_cpp.cmx ../../commons/common2.cmx ../../commons/common.cmx \ + token_views_cpp.cmi +token_views_cpp.cmi : parser_cpp.cmi ../../commons/ocaml.cmi +type_cpp.cmo : ast_cpp.cmo type_cpp.cmi +type_cpp.cmx : ast_cpp.cmx type_cpp.cmi +type_cpp.cmi : ast_cpp.cmo +unit_parsing_cpp.cmo : parse_cpp.cmi ../../commons/oUnit.cmi \ + flag_parsing_cpp.cmo ../../globals/config_pfff.cmo \ + ../../commons/common2.cmi ../../commons/common.cmi ast_cpp.cmo \ + unit_parsing_cpp.cmi +unit_parsing_cpp.cmx : parse_cpp.cmx ../../commons/oUnit.cmx \ + flag_parsing_cpp.cmx ../../globals/config_pfff.cmx \ + ../../commons/common2.cmx ../../commons/common.cmx ast_cpp.cmx \ + unit_parsing_cpp.cmi +unit_parsing_cpp.cmi : ../../commons/oUnit.cmi +visitor_cpp.cmo : ../../commons/ocaml.cmi ast_cpp.cmo visitor_cpp.cmi +visitor_cpp.cmx : ../../commons/ocaml.cmx ast_cpp.cmx visitor_cpp.cmi +visitor_cpp.cmi : ast_cpp.cmo diff --git a/lang_cpp/parsing/META b/lang_cpp/parsing/META new file mode 100644 index 0000000..a3b8cae --- /dev/null +++ b/lang_cpp/parsing/META @@ -0,0 +1,4 @@ +description = "C/C++ parser" +requires = "unix num" +archive(byte) = "lib.cma" +archive(native) = "lib.cmxa" diff --git a/lang_cpp/parsing/Makefile b/lang_cpp/parsing/Makefile new file mode 100644 index 0000000..5f0e80c --- /dev/null +++ b/lang_cpp/parsing/Makefile @@ -0,0 +1,101 @@ +TOP=../.. +############################################################################## +# Variables +############################################################################## +TARGET=lib + +-include $(TOP)/Makefile.config + +SRC= flag_parsing_cpp.ml \ + token_cpp.ml ast_cpp.ml \ + type_cpp.ml \ + meta_ast_cpp.ml \ + visitor_cpp.ml lib_parsing_cpp.ml \ + parser_cpp_mly_helper.ml parser_cpp.ml lexer_cpp.ml \ + token_helpers_cpp.ml token_views_cpp.ml token_views_context.ml \ + parsing_hacks_lib.ml pp_token.ml \ + parsing_hacks_pp.ml parsing_hacks_cpp.ml parsing_hacks_typedef.ml \ + parsing_hacks_define.ml \ + parsing_hacks.ml \ + parsing_recovery_cpp.ml \ + parse_cpp.ml \ + test_dump_nim.ml \ + test_parsing_cpp.ml unit_parsing_cpp.ml + +SYSLIBS= str.cma unix.cma + +LIBS=$(TOP)/commons/lib.cma \ + $(TOP)/h_program-lang/lib.cma + +INCLUDEDIRS= \ + $(TOP)/commons \ + $(TOP)/commons_core \ + $(TOP)/globals \ + $(TOP)/h_program-lang + +############################################################################## +# Generic variables +############################################################################## + +-include $(TOP)/Makefile.common + +############################################################################## +# Top rules +############################################################################## +all:: $(TARGET).cma +all.opt:: $(TARGET).cmxa + +$(TARGET).cma: $(OBJS) + $(OCAMLC) -a -o $(TARGET).cma $(OBJS) + +$(TARGET).cmxa: $(OPTOBJS) $(LIBS:.cma=.cmxa) + $(OCAMLOPT) -a -o $(TARGET).cmxa $(OPTOBJS) + +$(TARGET).top: $(OBJS) $(LIBS) + $(OCAMLMKTOP) -o $(TARGET).top $(SYSLIBS) $(LIBS) $(OBJS) + +clean:: + rm -f $(TARGET).top + + +lexer_cpp.ml: lexer_cpp.mll + $(OCAMLLEX) $< +clean:: + rm -f lexer_cpp.ml +beforedepend:: lexer_cpp.ml + + +parser_cpp.ml parser_cpp.mli: parser_cpp.mly + $(OCAMLYACC) $< +clean:: + rm -f parser_cpp.ml parser_cpp.mli parser_cpp.output +beforedepend:: parser_cpp.ml parser_cpp.mli + + +visitor_cpp.cmo: visitor_cpp.ml + $(OCAMLC) -w y -c $< + +parsing_hacks.cmo: parsing_hacks.ml + $(OCAMLC) -w -9 -c $< +parsing_hacks_cpp.cmo: parsing_hacks_cpp.ml + $(OCAMLC) -w -9 -c $< +parsing_hacks_pp.cmo: parsing_hacks_pp.ml + $(OCAMLC) -w -9 -c $< +parsing_hacks_typedef.cmo: parsing_hacks_typedef.ml + $(OCAMLC) -w -9 -c $< +token_views_context.cmo: token_views_context.ml + $(OCAMLC) -w -9 -c $< + + +############################################################################## +# install +############################################################################## +LIBNAME=pfff-lang_cpp +EXPORTSRC=meta_ast_cpp.mli \ + parser_cpp.mli parse_cpp.mli \ + lib_parsing_cpp.mli visitor_cpp.mli \ + +install-findlib: + ocamlfind install $(LIBNAME) META lib.cma lib.cmxa lib.a \ + $(EXPORTSRC) $(EXPORTSRC:%.mli=%.cmi) \ + ast_cpp.ml ast_cpp.cmi diff --git a/lang_cpp/parsing/ast_cpp.ml b/lang_cpp/parsing/ast_cpp.ml new file mode 100644 index 0000000..e301b50 --- /dev/null +++ b/lang_cpp/parsing/ast_cpp.ml @@ -0,0 +1,831 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010-2014 Facebook + * Copyright (C) 2008-2009 University of Urbana Champaign + * Copyright (C) 2006-2007 Ecole des Mines de Nantes + * Copyright (C) 2002 Yoann Padioleau + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * This is a big file ... C++ is a big and complicated language ... + * This file started with a simple AST for C. It was then extended + * to deal with cpp idioms (see 'cppext:' tag), gcc extensions (see gccext), + * and finally C++ constructs (see c++ext). A few kencc extensions + * were also recently added (see kenccext). + * + * gcc introduced StatementExpr which made expr and statement mutually + * recursive. It also added NestedFunc for even more mutual recursivity ... + * With C++ templates, because template arguments can be types or expressions + * and because templates are also qualifiers, almost all types + * are now mutually recursive ... + * + * Like most other ASTs in pfff, it's actually more a Concrete Syntax Tree. + * Some stuff are tagged 'semantic:' which means that they are computed + * after parsing. + * + * See also lang_c/parsing/ast_c.ml and lang_clang/parsing/ast_clang.ml + * (as well as mini/ast_minic.ml). + * + * todo: + * - migrate everything to wrap2, e.g. no more expressionbis, statementbis + * - support C++0x11, e.g. lambdas + * + * related work: + * - https://github.com/facebook/facebook-clang-plugins + * or https://github.com/Antique-team/clangml + * but by both using clang they work after preprocessing. This is + * fine for bug finding, but for codemap we need to parse as is, + * and we need to do it fast (calling clang is super expensive because + * calling cpp and parsing the end result is expensive) + * - EDG + * - see the CC'09 paper + *) + +(*****************************************************************************) +(* The AST C++ related types *) +(*****************************************************************************) +(* ------------------------------------------------------------------------- *) +(* Token/info *) +(* ------------------------------------------------------------------------- *) +type tok = Parse_info.info + +(* a shortcut to annotate some information with token/position information *) +and 'a wrap = 'a * tok list (* TODO: change to 'a * tok *) +and 'a wrap2 = 'a * tok + +and 'a paren = tok * 'a * tok +and 'a brace = tok * 'a * tok +and 'a bracket = tok * 'a * tok +and 'a angle = tok * 'a * tok + +and 'a comma_list = 'a wrap list +and 'a comma_list2 = ('a, tok (* the comma *)) Common.either list + (* with tarzan *) + +(* ------------------------------------------------------------------------- *) +(* Ident, name, scope qualifier *) +(* ------------------------------------------------------------------------- *) + +(* c++ext: in C 'name' and 'ident' are equivalent and are just strings. + * In C++ 'name' can have a complex form like 'A::B::list::size'. + * I use Q for qualified. I also have a special type to make the difference + * between intermediate idents (the classname or template_id) and final idents. + * Note that sometimes final idents are also classnames and can have final + * template_id. + * + * Sometimes some elements are not allowed at certain places, for instance + * converters can not have an associated Qtop. But I prefered to simplify + * and have a unique type for all those different kinds of names. + *) +type name = tok (*::*) option * (qualifier * tok (*::*)) list * ident + + and ident = + (* function name, macro name, variable, classname, enumname, namespace *) + | IdIdent of simple_ident + (* c++ext: *) + | IdTemplateId of simple_ident * template_arguments + | IdDestructor of tok(*~*) * simple_ident + | IdOperator of tok * (operator * tok list) + | IdConverter of tok * fullType + + and simple_ident = string wrap2 + + and template_arguments = template_argument comma_list angle + and template_argument = (fullType, expression) Common.either + + and qualifier = + | QClassname of simple_ident (* classname or namespacename *) + | QTemplateId of simple_ident * template_arguments + + (* special cases *) + and class_name = name (* only IdIdent or IdTemplateId *) + and namespace_name = name (* only IdIdent *) + and typedef_name = name (* only IdIdent *) + and enum_name = name (* only IdIdent *) + + and ident_name = name (* only IdIdent *) + +(* TODO: do like in parsing_c/ + * and ident_string = + * | RegularName of string wrap + * + * (* cppext: *) + * | CppConcatenatedName of (string wrap) wrap2 (* the ## separators *) list + * (* normally only used inside list of things, as in parameters or arguments + * * in which case, cf cpp-manual, it has a special meaning *) + * | CppVariadicName of string wrap (* ## s *) + * | CppIdentBuilder of string wrap (* s ( ) *) * + * ((string wrap) wrap2 list) (* arguments *) + *) + +(* ------------------------------------------------------------------------- *) +(* Types *) +(* ------------------------------------------------------------------------- *) +(* We could have a more precise type in fullType, in expression, etc, but + * it would require too much things at parsing time such as checking whether + * there is no conflicts structname, computing value, etc. It's better to + * separate concerns, so I put '=>' to mean what we would really like. In fact + * what we really like is defining another fullType, expression, etc + * from scratch, because many stuff are just sugar. + * + * invariant: Array and FunctionType have also typeQualifier but they + * dont have sense. I put this to factorise some code. If you look in + * grammar, you see that we can never specify const for the array + * himself (but we can do it for pointer). + *) +and fullType = typeQualifier * typeC + and typeC = typeCbis wrap + + (* less: rename to TBase, TPointer, etc *) + and typeCbis = + | BaseType of baseType + + | Pointer of (* '*' *) fullType + (* c++ext: *) + | Reference of (* '&' *) fullType + + | Array of constExpression option bracket * fullType + | FunctionType of functionType + + | EnumName of tok (* 'enum' *) * simple_ident (*enum_name*) + | StructUnionName of structUnion wrap2 * simple_ident (*ident_name*) + (* c++ext: TypeName can now correspond also to a classname or enumname + * and is a name so can have some IdTemplateId in it. + *) + | TypeName of name(*typedef_name*) + (* only to disambiguate I think *) + | TypenameKwd of tok (* 'typename' *) * name(*typedef_name*) + + (* gccext: TypeOfType may seems useless, why declare a __typeof__(int) + * x; ? But when used with macro, it allows to fix a problem of C which + * is that type declaration can be spread around the ident. Indeed it + * may be difficult to have a macro such as '#define macro(type, + * ident) type ident;' because when you want to do a macro(char[256], + * x), then it will generate invalid code, but with a '#define + * macro(type, ident) __typeof(type) ident;' it will work. *) + | TypeOf of tok * (fullType, expression) Common.either paren + + (* should be really just at toplevel *) + | EnumDef of enum_definition (* => string * int list *) + (* c++ext: bigger type now *) + | StructDef of class_definition + + (* forunparser: *) + | ParenType of fullType paren + + and baseType = + | Void + | IntType of intType + | FloatType of floatType + + (* stdC: type section. 'char' and 'signed char' are different *) + and intType = + | CChar (* obsolete? | CWchar *) + | Si of signed + (* c++ext: maybe could be put in baseType instead ? *) + | CBool | WChar_t + + and signed = sign * base + and base = + | CChar2 | CShort | CInt | CLong + (* gccext: *) + | CLongLong + and sign = Signed | UnSigned + + and floatType = CFloat | CDouble | CLongDouble + +and typeQualifier = + { const: tok option; volatile: tok option; } + +(* TODO: like in parsing_c/ + * (* gccext: cppext: *) + * and attribute = attributebis wrap + * and attributebis = + * | Attribute of string + *) + +(* ------------------------------------------------------------------------- *) +(* Expressions *) +(* ------------------------------------------------------------------------- *) + +(* Because of StatementExpr, we can have more 'new scope', but it's + * rare I think. For instance with 'array of constExpression' we could + * have an StatementExpr and a new (local) struct defined. Same for + * Constructor. + *) +and expression = expressionbis wrap + and expressionbis = + (* Id can be an enumeration constant, variable, function name. + * cppext: Id can also be the name of a macro. sparse says + * "an identifier with a meaning is a symbol". + * c++ext: Id is now a 'name' instead of a 'string' and can be + * also an operator name. + *) + | Id of name * ident_info (* semantic: see check_variables_cpp.ml *) + | C of constant + + (* I used to have FunCallSimple but not that useful, and we want scope info + * for FunCallSimple too because can have fn(...) where fn is actually + * a local *) + | Call of expression * argument comma_list paren + + (* gccext: x ? /* empty */ : y <=> x ? x : y; *) + | CondExpr of expression * expression option * expression + + (* should be considered as statements, bad C langage *) + | Sequence of expression * expression + | Assignment of expression * assignOp * expression + + | Postfix of expression * fixOp + | Infix of expression * fixOp + (* contains GetRef and Deref!! todo: lift up? *) + | Unary of expression * unaryOp + | Binary of expression * binaryOp * expression + + | ArrayAccess of expression * expression bracket + + (* The Pt is redundant normally, could be replace by DeRef RecordAccess *) + | RecordAccess of expression * name + | RecordPtAccess of expression * name + + (* c++ext: note that second paramater is an expression, not a name *) + | RecordStarAccess of expression * expression + | RecordPtStarAccess of expression * expression + + | SizeOfExpr of tok * expression + | SizeOfType of tok * fullType paren + + | Cast of fullType paren * expression + + (* gccext: *) + | StatementExpr of compound paren (* ( { } ) new scope*) + (* gccext: kenccext: *) + | GccConstructor of fullType paren * initialiser comma_list brace + + (* c++ext: *) + | This of tok + | ConstructedObject of fullType * argument comma_list paren + | TypeId of tok * (fullType, expression) Common.either paren + | CplusplusCast of cast_operator wrap2 * fullType angle * expression paren + | New of tok (*::*) option * tok * + argument comma_list paren option (* placement *) * + fullType * + argument comma_list paren option (* initializer *) + + | Delete of tok (*::*) option * expression + | DeleteArray of tok (*::*) option * expression + | Throw of expression option + + (* forunparser: *) + | ParenExpr of expression paren + + | ExprTodo + + (* see check_variables_cpp.ml *) + and ident_info = { + mutable i_scope: Scope_code.scope; + } + + (* cppext: normmally just expression *) + and argument = (expression, weird_argument) Common.either + and weird_argument = + | ArgType of fullType + (* for really unparsable stuff ... we just bailout *) + | ArgAction of action_macro + and action_macro = + | ActMisc of tok list + + (* I put 'string' for Int and Float because 'int' would not be enough. + * Indeed OCaml int are 31 bits. So it's simpler to use 'string'. + * Same reason to have 'string' instead of 'int list' for the String case. + * + * note: '-2' is not a constant; it is the unary operator '-' + * applied to the constant '2'. So the string must represent a positive + * integer only. + *) + and constant = + | Int of (string (* * intType*)) + | Float of (string * floatType) + | Char of (string * isWchar) (* normally it is equivalent to Int *) + | String of (string * isWchar) + | MultiString (* can contain MacroString *) + (* c++ext: *) + | Bool of bool + and isWchar = IsWchar | IsChar + + and unaryOp = + (* less: could be lift up, those are really important operators *) + | GetRef | DeRef + (* gccext: via &&label notation *) + | GetRefLabel + | UnPlus | UnMinus | Tilde | Not + and assignOp = SimpleAssign | OpAssign of arithOp + and fixOp = Dec | Inc + + and binaryOp = Arith of arithOp | Logical of logicalOp + and arithOp = + | Plus | Minus | Mul | Div | Mod + | DecLeft | DecRight + | And | Or | Xor + and logicalOp = + | Inf | Sup | InfEq | SupEq + | Eq | NotEq + | AndLog | OrLog + + (* c++ext: used elsewhere but prefer to define it close to other operators *) + and ptrOp = PtrStarOp | PtrOp + and allocOp = NewOp | DeleteOp | NewArrayOp | DeleteArrayOp + and accessop = ParenOp | ArrayOp + and operator = + | BinaryOp of binaryOp + | AssignOp of assignOp + | FixOp of fixOp + | PtrOpOp of ptrOp + | AccessOp of accessop + | AllocOp of allocOp + | UnaryTildeOp | UnaryNotOp | CommaOp + + (* c++ext: *) + and cast_operator = + | Static_cast | Dynamic_cast | Const_cast | Reinterpret_cast + + and constExpression = expression (* => int *) + +(* ------------------------------------------------------------------------- *) +(* Statements *) +(* ------------------------------------------------------------------------- *) +(* note: assignement is not a statement, it's an expression :( + * (wonderful C language). + * note: I use 'and' for type definition because gccext allows statements as + * expressions, so we need mutual recursive type definition now. + *) +and statement = statementbis wrap + and statementbis = + | Compound of compound (* new scope *) + | ExprStatement of exprStatement + | Labeled of labeled + | Selection of selection + | Iteration of iteration + | Jump of jump + + (* c++ext: in C this constructor could be outside the statement type, in a + * decl type, because declarations are only at the beginning of a compound + * normally. But in C++ we can freely mix declarations and statements. + *) + | DeclStmt of block_declaration + (* c++ext: *) + | Try of tok * compound * handler list + (* gccext: *) + | NestedFunc of func_definition + (* cppext: *) + | MacroStmt + + | StmtTodo + + (* cppext: c++ext: + * old: compound = (declaration list * statement list) + * old: (declaration, statement) either list + *) + and compound = statement_sequencable list brace + + and exprStatement = expression option + + and labeled = + | Label of string * statement + | Case of expression * statement + | CaseRange of expression * expression * statement (* gccext: *) + | Default of statement + + and selection = + | If of tok * expression paren * statement * tok option * statement + (* need to check that all elements in the compound start + * with a case:, otherwise it's unreachable code. + *) + | Switch of tok * expression paren * statement + + and iteration = + | While of tok * expression paren * statement + | DoWhile of tok * statement * tok * expression paren * tok (*;*) + | For of + tok * + (exprStatement wrap * exprStatement wrap * exprStatement wrap) paren * + statement + (* cppext: *) + | MacroIteration of simple_ident * argument comma_list paren * statement + + and jump = + | Goto of string + | Continue | Break + | Return | ReturnExpr of expression + (* gccext: goto *exp ';' *) + | GotoComputed of expression + + (* c++ext: *) + and handler = tok * exception_declaration paren * compound + and exception_declaration = + | ExnDeclEllipsis of tok + | ExnDecl of parameter + + (* easier to put at statement_list level than statement level *) + and statement_sequencable = + | StmtElem of statement + (* cppext: *) + | CppDirectiveStmt of cpp_directive + | IfdefStmt of ifdef_directive (* * statement list *) + + +(* ------------------------------------------------------------------------- *) +(* Block Declaration *) +(* ------------------------------------------------------------------------- *) +(* a.k.a declaration_statement *) +and block_declaration = + (* Before I had a Typedef constructor, but why make this special case and not + * have also StructDef, EnumDef, so that 'struct t {...} v' which would + * then generate two declarations. If you want a cleaner C AST use + * ast_c.ml. + * note: before the need for unparser, I didn't have a DeclList but just + * a Decl. + *) + | DeclList of onedecl comma_list * tok (*;*) + + (* cppext: todo? now factorize with MacroTop ? *) + | MacroDecl of tok list * simple_ident * argument comma_list paren * tok + (* c++ext: using namespace *) + | UsingDecl of (tok * name * tok (*;*)) + | UsingDirective of tok * tok (*'namespace'*) * namespace_name * tok(*;*) + | NameSpaceAlias of tok * simple_ident * tok (*=*) * namespace_name * tok(*;*) + (* gccext: *) + | Asm of tok * tok option (*volatile*) * asmbody paren * tok(*;*) + + (* gccext: *) + and asmbody = tok list (* string list *) * colon wrap (* : *) list + and colon = Colon of colon_option comma_list + and colon_option = colon_optionbis wrap + and colon_optionbis = ColonMisc | ColonExpr of expression paren + +(* ------------------------------------------------------------------------- *) +(* Variable definition (and also field definition) *) +(* ------------------------------------------------------------------------- *) + + (* note: onedecl includes prototype declarations and class_declarations! + * c++ext: onedecl now covers also field definitions as fields can have + * storage in C++. + *) + and onedecl = { + (* option cos can have empty declaration or struct tag declaration. + * kenccext: name can also be empty because of anonymous fields. + *) + v_namei: (name * init option) option; + v_type: fullType; + v_storage: storage; + (* v_attr: attribute list; *) (* gccext: *) + } + and storage = NoSto | StoTypedef of tok | Sto of storageClass wrap2 + and storageClass = Auto | Static | Register | Extern + (* Friend ???? Mutable? *) + + (*c++ext: TODO *) + (* I am not sure what it means to declare a prototype inline, but gcc + * accepts it. *) + and _func_specifier = Inline | Virtual + + and init = + | EqInit of tok (*=*) * initialiser + (* c++ext: constructed object *) + | ObjInit of argument comma_list paren + + and initialiser = + | InitExpr of expression + | InitList of initialiser comma_list brace + (* gccext: *) + | InitDesignators of designator list * tok (*=*) * initialiser + | InitFieldOld of simple_ident * tok (*:*) * initialiser + | InitIndexOld of expression bracket * initialiser + + (* ex: [2].y = x, or .y[2] or .y.x. They can be nested *) + and designator = + | DesignatorField of tok(*:*) * simple_ident + | DesignatorIndex of expression bracket + | DesignatorRange of (expression * tok (*...*) * expression) bracket + + +(* ------------------------------------------------------------------------- *) +(* Function definition *) +(* ------------------------------------------------------------------------- *) +(* Normally we should define another type functionType2 because there + * are more restrictions on what can define a function than a pointer + * function. For instance a function declaration can omit the name of the + * parameter wheras a function definition can not. But, in some cases such + * as 'f(void) {', there is no name too, so I simplified and reused the + * same functionType type for both declarations and function definitions. + *) +and func_definition = { + f_name: name; + f_type: functionType; + f_storage: storage; + (* todo: gccext: inline or not:, f_inline: tok option *) + f_body: compound; + (*f_attr: attribute list;*) (* gccext: *) + } + and functionType = { + ft_ret: fullType; (* fake return type for ctor/dtor *) + ft_params: parameter comma_list paren; + ft_dots: (tok(*,*) * tok(*...*)) option; + (* c++ext: *) + ft_const: tok option; (* only for methods *) + ft_throw: exn_spec option; + } + and parameter = { + p_name: simple_ident option; + p_type: fullType; + p_register: tok option; + (* c++ext: *) + p_val: (tok (*=*) * expression) option; + } + and exn_spec = (tok * name comma_list2 paren) + + (* less: simplify? need differentiate at this level? could have + * is_ctor, is_dtor helper instead. + *) + and func_or_else = + | FunctionOrMethod of func_definition + (* c++ext: special member function *) + | Constructor of func_definition (* TODO explicit/inline, chain_call *) + | Destructor of func_definition + + and method_decl = + | MethodDecl of onedecl * (tok * tok) option (* '=' '0' *) * tok(*;*) + | ConstructorDecl of + simple_ident * parameter comma_list paren * tok(*;*) + | DestructorDecl of + tok(*~*) * simple_ident * tok option paren * exn_spec option * tok(*;*) + +(* ------------------------------------------------------------------------- *) +(* enum definition *) +(* ------------------------------------------------------------------------- *) +(* less: use a record *) +and enum_definition = + tok (*enum*) * simple_ident option * enum_elem comma_list brace + + and enum_elem = { + e_name: simple_ident; + e_val: (tok (*=*) * constExpression) option; + } + +(* ------------------------------------------------------------------------- *) +(* Class definition *) +(* ------------------------------------------------------------------------- *) +and class_definition = { + c_kind: structUnion wrap2; + (* the ident can be a template_id when do template specialization. *) + c_name: ident_name(*class_name??*) option; + (* c++ext: *) + c_inherit: (tok (* ':' *) * base_clause comma_list) option; + c_members: class_member_sequencable list brace (* new scope *); + } + and structUnion = + | Struct | Union + (* c++ext: *) + | Class + + and base_clause = { + i_name: class_name; + i_virtual: tok option; + i_access: access_spec wrap2 option; + } + + (* used in inheritance spec (base_clause) and class_member *) + and access_spec = Public | Private | Protected + + (* was called field wrap before *) + and class_member = + (* could put outside and take class_member list *) + | Access of access_spec wrap2 * tok (*:*) + + (* before unparser, I didn't have a FieldDeclList but just a Field. *) + | MemberField of fieldkind comma_list * tok (*';'*) + | MemberFunc of func_or_else + | MemberDecl of method_decl + + | QualifiedIdInClass of name (* ?? *) * tok(*;*) + + | TemplateDeclInClass of (tok * template_parameters * declaration) + | UsingDeclInClass of (tok (*using*) * name * tok (*;*)) + + (* gccext: and maybe c++ext: *) + | EmptyField of tok (*;*) + + (* At first I thought that a bitfield could be only Signed/Unsigned. + * But it seems that gcc allow char i:4. C rule must say that you + * can cast into int so enum too, ... + * c++ext: FieldDecl was before Simple of string option * fullType + * but in c++ fields can also have storage (e.g. static) so now reuse + * ondecl. + *) + and fieldkind = + | FieldDecl of onedecl + | BitField of simple_ident option * tok(*:*) * + fullType * constExpression + (* fullType => BitFieldInt | BitFieldUnsigned *) + + and class_member_sequencable = + | ClassElem of class_member + (* cppext: *) + | CppDirectiveStruct of cpp_directive + | IfdefStruct of ifdef_directive (* * field list *) + +(* ------------------------------------------------------------------------- *) +(* cppext: cpp directives, #ifdef, #define and #include body *) +(* ------------------------------------------------------------------------- *) +and cpp_directive = + | Define of tok (* #define*) * simple_ident * define_kind * define_val + | Include of tok (* #include s *) * inc_kind * string (* path *) + | Undef of simple_ident (* #undef xxx *) + | PragmaAndCo of tok + + and define_kind = + | DefineVar + | DefineFunc of string wrap comma_list paren + and define_val = + | DefineExpr of expression + | DefineStmt of statement + | DefineType of fullType + | DefineFunction of func_definition + | DefineInit of initialiser (* in practice only { } with possible ',' *) + (* ?? *) + | DefineText of string wrap + | DefineEmpty + + | DefineDoWhileZero of statement wrap (* do { } while(0) *) + | DefinePrintWrapper of tok (* if *) * expression paren * name + + | DefineTodo + + and inc_kind = + | Local (* "" *) + | Standard (* <> *) + | Weird (* ex: #include SYSTEM_H *) + + (* less: 'a ifdefed = 'a list wrap (* ifdef elsif else endif *) *) + and ifdef_directive = ifdefkind wrap2 + and ifdefkind = + | Ifdef (* todo? of string? *) + (* less: IfIf of formula_cpp ? *) + | IfdefElse + | IfdefElseif + | IfdefEndif + (* less: + * set in Parsing_hacks.set_ifdef_parenthize_info. It internally use + * a global so it means if you parse the same file twice you may get + * different id. I try now to avoid this pb by resetting it each + * time I parse a file. + * + * and matching_tag = + * IfdefTag of (int (* tag *) * int (* total with this tag *)) + *) + +(* ------------------------------------------------------------------------- *) +(* The toplevel elements *) +(* ------------------------------------------------------------------------- *) +(* it's not really 'toplevel' because the elements below can be nested + * inside namespaces or some extern. It's not really 'declaration' + * either because it can defines stuff. But I keep the C++ standard + * terminology. + * + * note that we use 'block_declaration' below, not 'statement'. + *) +and declaration = + | BlockDecl of block_declaration (* include struct/globals/... definitions *) + | Func of func_or_else + + (* c++ext: *) + | TemplateDecl of tok * template_parameters * declaration + | TemplateSpecialization of tok * unit angle * declaration + (* the list can be empty *) + | ExternC of tok * tok * declaration + | ExternCList of tok * tok * declaration_sequencable list brace + (* the list can be empty *) + | NameSpace of tok * simple_ident * declaration_sequencable list brace + (* after have some semantic info *) + | NameSpaceExtend of string * declaration_sequencable list + | NameSpaceAnon of tok * declaration_sequencable list brace + + (* gccext: allow redundant ';' *) + | EmptyDef of tok + + | DeclTodo + + (* c++ext: *) + and template_parameter = parameter (* todo? more? *) + and template_parameters = template_parameter comma_list angle + + (* easier to put at statement_list level than statement level *) + and declaration_sequencable = + | DeclElem of declaration + (* cppext: *) + | CppDirectiveDecl of cpp_directive + | IfdefDecl of ifdef_directive (* * toplevel list *) + (* cppext: *) + | MacroTop of simple_ident * argument comma_list paren * tok option + | MacroVarTop of simple_ident * tok (* ; *) + (* could also be in decl *) + | NotParsedCorrectly of tok list + +and toplevel = declaration_sequencable + +and program = toplevel list + +(* ------------------------------------------------------------------------- *) +(* Any *) +(* ------------------------------------------------------------------------- *) +and any = + | Program of program + | Toplevel of toplevel + | Cpp of cpp_directive + | Stmt of statement + | Expr of expression + | Type of fullType + | Name of name + + | BlockDecl2 of block_declaration + | ClassDef of class_definition + | FuncDef of func_definition + | FuncOrElse of func_or_else + | ClassMember of class_member + | OneDecl of onedecl + | Init of initialiser + + | Constant of constant + + | Argument of argument + | Parameter of parameter + + | Body of compound + + | Info of tok + | InfoList of tok list + + (* with tarzan *) + +(*****************************************************************************) +(* Some constructors *) +(*****************************************************************************) +let nQ = {const=None; volatile= None} +let noIdInfo () = { i_scope = Scope_code.NoScope; } +let noii = [] +let noQscope = [] + +(*****************************************************************************) +(* Wrappers *) +(*****************************************************************************) +let unwrap x = fst x +let uncomma xs = List.map fst xs +let unparen (_, x, _) = x +let unbrace (_, x, _) = x + +let unwrap_typeC (_qu, (typeC, _ii)) = typeC + +(* When want add some info in AST that does not correspond to + * an existing C element. + * old: when don't want 'synchronize' on it in unparse_c.ml + * (now have other mark for tha matter). + * used by parsing hacks + *) +let make_expanded ii = + let noVirtPos = ({Parse_info.str="";charpos=0;line=0;column=0;file=""},-1) in + let (a, b) = noVirtPos in + { ii with Parse_info.token = Parse_info.ExpandedTok + (Parse_info.get_original_token_location ii.Parse_info.token, a, b) } + +(* used by parsing hacks *) +let rewrap_pinfo pi ii = + {ii with Parse_info.token = pi} + + +(* used while migrating the use of 'string' to 'name' in check_variables *) +let (string_of_name_tmp: name -> string) = fun name -> + let (_opt, _qu, id) = name in + match id with + | IdIdent (s,_) -> s + | _ -> failwith "TODO:string_of_name_tmp" + +let (ii_of_id_name: name -> tok list) = fun name -> + let (_opt, _qu, id) = name in + match id with + | IdIdent (_s,ii) -> [ii] + | IdOperator (_, (_op, ii)) -> ii + | IdConverter (_tok, _ft) -> failwith "ii_of_id_name: IdConverter" + | IdDestructor (tok, (_s, ii)) -> [tok;ii] + | IdTemplateId ((_s, ii), _args) -> [ii] diff --git a/lang_cpp/parsing/authors.txt b/lang_cpp/parsing/authors.txt new file mode 100644 index 0000000..2b64d46 --- /dev/null +++ b/lang_cpp/parsing/authors.txt @@ -0,0 +1,2 @@ +Yoann Padioleau + diff --git a/lang_cpp/parsing/conflicts.txt b/lang_cpp/parsing/conflicts.txt new file mode 100644 index 0000000..be1ec88 --- /dev/null +++ b/lang_cpp/parsing/conflicts.txt @@ -0,0 +1,93 @@ +-*- org -*- + +TODO: +http://blog.robertelder.org/jim-roskind-grammar/ + +http://eli.thegreenplace.net/2007/11/24/the-context-sensitivity-of-cs-grammar/ + +* Typedefs + +simple_type_specifier: + ... + | type_cplusplus_id { Right3 (TypeName $1), noii } + + (* history: cant put TIdent {} cos it makes the grammar ambiguous and + * generates lots of conflicts => we must use some tricks. + * We used make the lexer and parser cooperate (in a lexerParser.ml file). + * But this was not enough because of declarations such as 'acpi acpi;' + * and so we had to enable/disable the ident->typedef mechanism + * (which requires even more lexer/parser cooperation). But + * this was ugly too so now we use a typedef "inference" mechanism. + +We do many things to handle typedefs ambiguities: + - parsing_hack_typedef heuristics + - token_view_context in Parameter heuristics + - dealing with template before the actual typedef + - a few rules added for parameter and arguments to allow + both TIdent and TIdent_typedef in both contexts + - ... + + +** pointer decl, multiplication and ambiguity + +from "Yacc Is Dead" at http://lambda-the-ultimate.org/node/4148#comment + +" 'x*y;' in C++ this could be a multiplication, pointer declaration, or +arbitrary overloaded meaning of "*". You have to hit name and type +resolution before you can distinguish them." + +** cast and ambiguity + +can be cast or binary minus + (u32int)-pa + +can be cast or funcall + (u32int)(-pa)); + +same with (uintptr)&x. + +* If-then-else + +see dangling-else section in lang_php/parsing/conflicts.txt + +* Template < > + +We do many things ... + +* C++ + +* TODO ':' + +When have 'class X :' we don't know if it's the start of possibly a +class with inheritance spec, or a bitfield as 'class X :3'. + +TODO why have conflict on TCol ??? + + +* Old notes + +(* Cocci: Each token will be decorated in the future by the mcodekind + * of cocci. It is the job of the pretty printer to look at this + * information and decide to print or not the token (and also the + * pending '+' associated sometimes with the token). + * + * The first time that we parse the original C file, the mcodekind is + * empty, or more precisely all is tagged as a CONTEXT with NOTHING + * associated. This is what I call a "clean" expr/statement/.... + * + * Each token will also be decorated in the future with an environment, + * because the pending '+' may contain metavariables that refer to some + * C code. + * + * Update: Now I use a ref! so take care. + * + * Sometimes we want to add someting at the beginning or at the end + * of a construct. For 'function' and 'decl' we want add something + * to their left and for 'if' 'while' et 'for' and so on at their right. + * We want some kinds of "virtual placeholders" that represent the start or + * end of a construct. We use fakeInfo for that purpose. + * To identify those cases I have added a fakestart/fakeend comment. + * + * convention: I often use 'ii' for the name of a list of info. + * + *) diff --git a/lang_cpp/parsing/copyright.txt b/lang_cpp/parsing/copyright.txt new file mode 100644 index 0000000..a826dc6 --- /dev/null +++ b/lang_cpp/parsing/copyright.txt @@ -0,0 +1,14 @@ +parsing_c++ library - Yoann Padioleau + +Copyright (C) 2002-2008 Yoann Padioleau, University of Urbana Champaign, +Ecole des Mines de Nantes, Universite de Rennes 1. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License (GPL) + version 2 as published by the Free Software Foundation. + + 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 + file license.txt for more details. + diff --git a/lang_cpp/parsing/credits.txt b/lang_cpp/parsing/credits.txt new file mode 100644 index 0000000..955fed3 --- /dev/null +++ b/lang_cpp/parsing/credits.txt @@ -0,0 +1,9 @@ +Thanks to Julia Lawall for the idea to better parse C+CPP by using +indentation information for heuristic-based parsing. Thanks to Julia +again for many other things too long to enumerate. + +Inspiration: + - C yacc grammar published in 1985 by Jeff Lee: + lex: http://www.lysator.liu.se/c/ANSI-C-grammar-l.html + yacc: http://www.lysator.liu.se/c/ANSI-C-grammar-y.html + diff --git a/lang_cpp/parsing/flag_parsing_cpp.ml b/lang_cpp/parsing/flag_parsing_cpp.ml new file mode 100644 index 0000000..e5a1905 --- /dev/null +++ b/lang_cpp/parsing/flag_parsing_cpp.ml @@ -0,0 +1,77 @@ + +(*****************************************************************************) +(* types *) +(*****************************************************************************) + +type language = + | C + | Cplusplus + +(*****************************************************************************) +(* macros *) +(*****************************************************************************) + +let macros_h = + ref (Filename.concat Config_pfff.path "/data/cpp_stdlib/macros.h") + +let cmdline_flags_macrofile () = [ + "-macros", Arg.Set_string macros_h, + " "; +] + +(*****************************************************************************) +(* verbose *) +(*****************************************************************************) + +let verbose_lexing = ref true +let verbose_parsing = ref true + +(* do not raise Parse_error in parse_cpp.ml, try to recover! *) +let error_recovery = ref true +let show_parsing_error = ref true + +let verbose_pp_ast = ref false + +let filter_msg = ref false +let filter_classic_passed = ref false +let filter_define_error = ref true + +let cmdline_flags_verbose () = [ + "-verbose_parsing_cpp", Arg.Set verbose_parsing, " "; +] + +(*****************************************************************************) +(* debugging *) +(*****************************************************************************) + +let debug_lexer = ref false + +let debug_typedef = ref false +let debug_pp = ref false +let debug_pp_ast = ref false +let debug_cplusplus = ref false + +let cmdline_flags_debugging () = [ + "-debug_lexer_cpp", Arg.Set debug_lexer , " "; + + "-debug_pp", Arg.Set debug_pp, " "; + "-debug_typedef", Arg.Set debug_typedef, " "; + "-debug_cplusplus", Arg.Set debug_cplusplus, " "; + + "-debug_cpp", Arg.Unit (fun () -> + debug_pp := true; + debug_typedef := true; + debug_cplusplus := true; + ), " "; +] + +(*****************************************************************************) +(* Disable parsing features *) +(*****************************************************************************) + +let strict_lexer = ref false + +let if0_passing = ref true +let ifdef_to_if = ref false + +let sgrep_mode = ref false diff --git a/lang_cpp/parsing/lexer_cpp.mll b/lang_cpp/parsing/lexer_cpp.mll new file mode 100644 index 0000000..f479f7d --- /dev/null +++ b/lang_cpp/parsing/lexer_cpp.mll @@ -0,0 +1,710 @@ +{ +(* Yoann Padioleau + * + * Copyright (C) 2002 Yoann Padioleau + * Copyright (C) 2006-2007 Ecole des Mines de Nantes + * Copyright (C) 2008-2009 University of Urbana Champaign + * Copyright (C) 2010-2013 Facebook + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +open Parser_cpp +open Ast_cpp (* to factorise tokens with OpAssign, ... *) + +module Flag = Flag_parsing_cpp +module Ast = Ast_cpp +module PI = Parse_info + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(* The C/cpp/C++ lexer. + * + * This lexer generates tokens for C (int, while, ...), C++ (new, delete, ...), + * CPP (#define, #ifdef, ...). + * It also generate tokens for comments and spaces. This means that + * it can not be used as-is. Some post-filtering + * has to be done to feed it to a parser. Note that C and C++ are not + * context free languages and so some idents must be disambiguated + * in some ways. TIdent below must thus be post-processed too (as well + * as other tokens like '<' for C++). See parsing_hack.ml for examples. + * + * note: We can't use Lexer_parser._lexer_hint here to do different + * things because we now call the lexer to get all the tokens + * and then only we parse. So we can use the hint only + * in parse_cpp.ml. For the same reason, we don't handle typedefs + * here anymore. We really just tokenize ... + *) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) +exception Lexical of string + +let error s = + if !Flag.strict_lexer + then raise (Lexical s) + else + if !Flag.verbose_lexing + then pr2 ("LEXER: " ^ s) + else () + +let tok lexbuf = + Lexing.lexeme lexbuf + +let tokinfo lexbuf = + Parse_info.tokinfo_str_pos (tok lexbuf) (Lexing.lexeme_start lexbuf) + +let tok_add_s = Parse_info.tok_add_s + +(* ---------------------------------------------------------------------- *) +(* Keywords *) +(* ---------------------------------------------------------------------- *) + +(* opti: less convenient, but using a hash is faster than using a match *) +let keyword_table = Common.hash_of_list [ + + (* c: *) + "void", (fun ii -> Tvoid ii); + "char", (fun ii -> Tchar ii); + "short", (fun ii -> Tshort ii); "int", (fun ii -> Tint ii); + "long", (fun ii -> Tlong ii); + "float", (fun ii -> Tfloat ii); "double", (fun ii -> Tdouble ii); + + "unsigned", (fun ii -> Tunsigned ii); "signed", (fun ii -> Tsigned ii); + + "auto", (fun ii -> Tauto ii); + "register", (fun ii -> Tregister ii); + "extern", (fun ii -> Textern ii); + "static", (fun ii -> Tstatic ii); + + "const", (fun ii -> Tconst ii); "volatile", (fun ii -> Tvolatile ii); + + "struct", (fun ii -> Tstruct ii); + "union", (fun ii -> Tunion ii); + "enum", (fun ii -> Tenum ii); + + "typedef", (fun ii -> Ttypedef ii); + + "if", (fun ii -> Tif ii); "else", (fun ii -> Telse ii); + "break", (fun ii -> Tbreak ii); "continue", (fun ii -> Tcontinue ii); + "switch", (fun ii -> Tswitch ii); + "case", (fun ii -> Tcase ii); "default", (fun ii -> Tdefault ii); + "for", (fun ii -> Tfor ii); + "do", (fun ii -> Tdo ii); + "while", (fun ii -> Twhile ii); + "return", (fun ii -> Treturn ii); + "goto", (fun ii -> Tgoto ii); + + "sizeof", (fun ii -> Tsizeof ii); + + (* gccext: more (cpp) aliases are in macros.h *) + "asm", (fun ii -> Tasm ii); + "__attribute__", (fun ii -> Tattribute ii); + "typeof", (fun ii -> Ttypeof ii); + (* also a c++ext: *) + "inline", (fun ii -> Tinline ii); + + (* c99: *) + "__restrict__", (fun ii -> Trestrict ii); + + (* c++ext: see also TH.is_cpp_keyword *) + "class", (fun ii -> Tclass ii); + "this", (fun ii -> Tthis ii); + + "new" , (fun ii -> Tnew ii); + "delete" , (fun ii -> Tdelete ii); + + "template" , (fun ii -> Ttemplate ii); + "typeid" , (fun ii -> Ttypeid ii); + "typename" , (fun ii -> Ttypename ii); + + "catch" , (fun ii -> Tcatch ii); + "try" , (fun ii -> Ttry ii); + "throw" , (fun ii -> Tthrow ii); + + "operator", (fun ii -> Toperator ii); + + "public" , (fun ii -> Tpublic ii); + "private" , (fun ii -> Tprivate ii); + "protected" , (fun ii -> Tprotected ii); + + "friend" , (fun ii -> Tfriend ii); + + "virtual", (fun ii -> Tvirtual ii); + + "namespace", (fun ii -> Tnamespace ii); + "using", (fun ii -> Tusing ii); + + "bool", (fun ii -> Tbool ii); + + "true", (fun ii -> Ttrue ii); "false", (fun ii -> Tfalse ii); + + "wchar_t", (fun ii -> Twchar_t ii); + + "const_cast" , (fun ii -> Tconst_cast ii); + "dynamic_cast" , (fun ii -> Tdynamic_cast ii); + "static_cast" , (fun ii -> Tstatic_cast ii); + "reinterpret_cast" , (fun ii -> Treinterpret_cast ii); + + "explicit", (fun ii -> Texplicit ii); + "mutable", (fun ii -> Tmutable ii); + + "export", (fun ii -> Texport ii); + ] + +let error_radix s = + ("numeric " ^ s ^ " constant contains digits beyond the radix:") + +} +(*****************************************************************************) +(* Regexps aliases *) +(*****************************************************************************) +let letter = ['A'-'Z' 'a'-'z' '_'] +let digit = ['0'-'9'] + +(* not used for the moment *) +let punctuation = ['!' '"' '#' '%' '&' '\'' '(' ')' '*' '+' ',' '-' '.' '/' ':' + ';' '<' '=' '>' '?' '[' '\\' ']' '^' '{' '|' '}' '~'] +let space = [' ' '\t' '\n' '\r' '\011' '\012' ] +let additionnal = [ ' ' '\b' '\t' '\011' '\n' '\r' '\007' ] +(* 7 = \a = bell in C. this is not the only char allowed !! + * ex @ and $ ` are valid too + *) + +let cchar = (letter | digit | punctuation | additionnal) + +let sp = [' ' '\t']+ +let spopt = [' ' '\t']* + +let dec = ['0'-'9'] +let oct = ['0'-'7'] +let hex = ['0'-'9' 'a'-'f' 'A'-'F'] + +let decimal = ('0' | (['1'-'9'] dec*)) +let octal = ['0'] oct+ +let hexa = ("0x" |"0X") hex+ + +let pent = dec+ +let pfract = dec+ +let sign = ['-' '+'] +let exp = ['e''E'] sign? dec+ +let real = pent exp | ((pent? '.' pfract | pent '.' pfract? ) exp?) + +let id = letter (letter | digit) * + +(*****************************************************************************) +(* Rule token *) +(*****************************************************************************) +rule token = parse + + (* ----------------------------------------------------------------------- *) + (* Spaces, comments *) + (* ----------------------------------------------------------------------- *) + + (* note: this lexer generate tokens for comments! So we can not give + * this lexer as-is to the parsing function. We must postprocess it, and + * use techniques like cur_tok ref in parse_cpp.ml + *) + + | [' ' '\t' ]+ + { TCommentSpace (tokinfo lexbuf) } + + (* see also TCppEscapedNewline below *) + | [ '\n' '\r' '\011' '\012'] + { TCommentNewline (tokinfo lexbuf) } + + | "/*" + { let info = tokinfo lexbuf in + let com = comment lexbuf in + TComment(info +> tok_add_s com) + } + + (* C++ comments are allowed via gccext, but normally they are deleted by cpp. + * So we need this here only because we dont call cpp before. + * Note that we don't keep the trailing \n; it will be in another token. + *) + | "//" [^'\r' '\n' '\011']* { TComment (tokinfo lexbuf) } + + (* ---------------------- *) + (* #include *) + (* ---------------------- *) + + (* The difference between a local "" and standard <> include is computed + * later in parser_cpp.mly. So we redo a little bit of lexing there. It's + * ugly but simpler to generate a single token here. *) + | (("#" [' ''\t']* ("include" | "include_next" | "import") + [' ' '\t']*) as includes) + (('"' ([^ '"']+) '"' | + '<' [^ '>']+ '>' | + ['A'-'Z''_']+ + ) as filename) + { (* less: generate 2 info so highlight_cpp.ml can colorize the + * directive and the filename differently + *) + TInclude (includes, filename, tokinfo lexbuf) + } + + (* ---------------------- *) + (* #ifdef *) + (* ---------------------- *) + + | "#" [' ' '\t']* "if" [' ' '\t']* '0' (* [^'\n']* '\n' *) + { let info = tokinfo lexbuf in + TIfdefBool (false, info(* +> tok_add_s (cpp_eat_until_nl lexbuf)*)) + } + | "#" [' ' '\t']* "if" [' ' '\t']* '1' (* [^'\n']* '\n' *) + { let info = tokinfo lexbuf in + TIfdefBool (true, info) + } + | "#" [' ' '\t']* "ifdef" [' ' '\t']* "__cplusplus" [^'\n']* '\n' + { let info = tokinfo lexbuf in + TIfdefMisc (false, info) + } + + (* can have some ifdef 0 hence the letter|digit even at beginning of word *) + | "#" [' ''\t']* "ifdef" [' ''\t']+ (letter|digit)((letter|digit)*) [' ''\t']* + { TIfdef (tokinfo lexbuf) } + | "#" [' ''\t']* "ifndef" [' ''\t']+ (letter|digit)((letter|digit)*)[' ''\t']* + { TIfdef (tokinfo lexbuf) } + | "#" [' ''\t']* "if" [' ' '\t']+ + { let info = tokinfo lexbuf in + TIfdef (info +> tok_add_s (cpp_eat_until_nl lexbuf)) + } + | "#" [' ' '\t']* "if" '(' + { let info = tokinfo lexbuf in + TIfdef (info +> tok_add_s (cpp_eat_until_nl lexbuf)) + } + + | "#" [' ' '\t']* "elif" [' ' '\t']+ + { let info = tokinfo lexbuf in + TIfdefelif (info +> tok_add_s (cpp_eat_until_nl lexbuf)) + } + + (* bugfix: can have #endif LINUX but at the same time if I eat everything + * until next line, I may miss some TComment which for some tools + * are important such as aComment + *) + | "#" [' ' '\t']* "endif" (*[^'\n']* '\n'*) + { TEndif (tokinfo lexbuf) } + | "#" [' ' '\t']* "else" [' ' '\t' '\n'] + { TIfdefelse (tokinfo lexbuf) } + + (* ---------------------- *) + (* #define, #undef *) + (* ---------------------- *) + + (* The rest of the lexing/parsing of #define is done in fix_tokens_define + * where we parse all TCppEscapedNewline and finally generate a TDefEol + *) + | "#" [' ' '\t']* "define" { TDefine (tokinfo lexbuf) } + + (* note: in some cases we can have stuff after the ident as in #undef XXX 50, + * but I currently don't handle it cos I think it's bad code. + *) + | (("#" [' ' '\t']* "undef" [' ' '\t']+) as _undef) (id as id) + (* alt: +> tok_add_s (cpp_eat_until_nl lexbuf)) *) + { TUndef (id, tokinfo lexbuf) } + + (* ---------------------- *) + (* #define body *) + (* ---------------------- *) + + (* We could generate separate tokens for #, ## and then extend + * the grammar, but there can be ident in many different places, in + * expression but also in declaration, in function name. So having 3 tokens + * for an ident does not work well with how we add info in + * ast_cpp.ml. So it's better to generate just one token, just one info, + * even if have later to reanalyse those tokens and unsplit. + * + * less: do as in yacfe, generate multiple tokens for those constructs? + *) + + | ((id as s) "...") + { TDefParamVariadic (s, tokinfo lexbuf) } + + (* cppext: string concatenation *) + | id ([' ''\t']* "##" [' ''\t']* id)+ + { let info = tokinfo lexbuf in + TIdent (tok lexbuf, info) + } + + (* cppext: stringification + * bugfix: this case must be after the other cases such as #endif + * otherwise take precedent. + *) + | "#" (*spopt*) id + { let info = tokinfo lexbuf in + TIdent (tok lexbuf, info) + } + + (* cppext: gccext: ##args for variadic macro *) + | "##" [' ''\t']* id + { let info = tokinfo lexbuf in + TIdent (tok lexbuf, info) + } + + (* only in define body normally *) + | "\\" '\n' { TCppEscapedNewline (tokinfo lexbuf) } + + (* ---------------------- *) + (* cpp pragmas *) + (* ---------------------- *) + + (* bugfix: I want to keep comments so cant do a sp [^'\n']+ '\n' + * http://gcc.gnu.org/onlinedocs/gcc/Pragmas.html + *) + | "#" spopt "pragma" sp [^'\n']* '\n' + | "#" spopt "ident" sp [^'\n']* '\n' + | "#" spopt "line" sp [^'\n']* '\n' + | "#" spopt "error" sp [^'\n']* '\n' + | "#" spopt "warning" sp [^'\n']* '\n' + | "#" spopt "abort" sp [^'\n']* '\n' + { TCppDirectiveOther (tokinfo lexbuf) } + + (* This appears only after calling cpp cpp, as in: + * # 1 "include/linux/module.h" 1 + * Because we handle cpp ourselves, why handle it here? + * Why not ... also one could want to use our parser on + * expanded files sometimes. + *) + | "#" sp pent sp '"' [^ '"']* '"' (spopt pent)* spopt '\n' + { TCppDirectiveOther (tokinfo lexbuf) } + + (* ?? *) + | "#" [' ' '\t']* '\n' + { TCppDirectiveOther (tokinfo lexbuf) } + + (* ----------------------------------------------------------------------- *) + (* C symbols *) + (* ----------------------------------------------------------------------- *) + (* stdC: + * ... && -= >= ~ + ; ] + * <<= &= -> >> % , < ^ + * >>= *= /= ^= & - = { + * != ++ << |= ( . > | + * %= += <= || ) / ? } + * -- == ! * : [ + * recent addition: <: :> <% %> + * only at processing: %: %:%: # ## + *) + + | '[' { TOCro(tokinfo lexbuf) } | ']' { TCCro(tokinfo lexbuf) } + | '(' { TOPar(tokinfo lexbuf) } | ')' { TCPar(tokinfo lexbuf) } + | '{' { TOBrace(tokinfo lexbuf) } | '}' { TCBrace(tokinfo lexbuf) } + + | '+' { TPlus(tokinfo lexbuf) } | '*' { TMul(tokinfo lexbuf) } + | '-' { TMinus(tokinfo lexbuf) } | '/' { TDiv(tokinfo lexbuf) } + | '%' { TMod(tokinfo lexbuf) } + + | "++"{ TInc(tokinfo lexbuf) } | "--"{ TDec(tokinfo lexbuf) } + + | "=" { TEq(tokinfo lexbuf) } + + | "-=" { TAssign (OpAssign Minus, (tokinfo lexbuf))} + | "+=" { TAssign (OpAssign Plus, (tokinfo lexbuf))} + | "*=" { TAssign (OpAssign Mul, (tokinfo lexbuf))} + | "/=" { TAssign (OpAssign Div, (tokinfo lexbuf))} + | "%=" { TAssign (OpAssign Mod, (tokinfo lexbuf))} + | "&=" { TAssign (OpAssign And, (tokinfo lexbuf))} + | "|=" { TAssign (OpAssign Or, (tokinfo lexbuf)) } + | "^=" { TAssign(OpAssign Xor, (tokinfo lexbuf))} + | "<<=" {TAssign (OpAssign DecLeft, (tokinfo lexbuf)) } + | ">>=" {TAssign (OpAssign DecRight, (tokinfo lexbuf))} + + | "==" { TEqEq(tokinfo lexbuf) } | "!=" { TNotEq(tokinfo lexbuf) } + | ">=" { TSupEq(tokinfo lexbuf) } | "<=" { TInfEq(tokinfo lexbuf) } + (* c++ext: transformed in TInf_Template in parsing_hacks_cpp.ml *) + | "<" { TInf(tokinfo lexbuf) } | ">" { TSup(tokinfo lexbuf) } + + | "&&" { TAndLog(tokinfo lexbuf) } | "||" { TOrLog(tokinfo lexbuf) } + | ">>" { TShr(tokinfo lexbuf) } | "<<" { TShl(tokinfo lexbuf) } + | "&" { TAnd(tokinfo lexbuf) } | "|" { TOr(tokinfo lexbuf) } + | "^" { TXor(tokinfo lexbuf) } + | "..." { TEllipsis(tokinfo lexbuf) } + | "->" { TPtrOp(tokinfo lexbuf) } | '.' { TDot(tokinfo lexbuf) } + | ',' { TComma(tokinfo lexbuf) } + | ";" { TPtVirg(tokinfo lexbuf) } + | "?" { TWhy(tokinfo lexbuf) } | ":" { TCol(tokinfo lexbuf) } + | "!" { TBang(tokinfo lexbuf) } | "~" { TTilde(tokinfo lexbuf) } + + + | "<:" { TOCro(tokinfo lexbuf) } | ":>" { TCCro(tokinfo lexbuf) } + | "<%" { TOBrace(tokinfo lexbuf) } | "%>" { TCBrace(tokinfo lexbuf) } + + (* c++ext: *) + | "::" { TColCol(tokinfo lexbuf) } + | "->*" { TPtrOpStar(tokinfo lexbuf) } | ".*" { TDotStar(tokinfo lexbuf) } + + (* ----------------------------------------------------------------------- *) + (* C keywords and ident *) + (* ----------------------------------------------------------------------- *) + + (* StdC: "must handle at least name of length > 509, but can + * truncate to 31 when compare and truncate to 6 and even lowerise + * in the external linkage phase" + *) + | letter (letter | digit) * + { let info = tokinfo lexbuf in + let s = tok lexbuf in + Common.profile_code "C parsing.lex_ident" (fun () -> + match Common2.optionise (fun () -> Hashtbl.find keyword_table s) with + | Some f -> f info + + (* typedef_hack. note: now this is no more useful, cos + * as we use tokens_all, we first parse then all as idents and + * later transform some idents into typedefs. So this job is + * now done in parse_cpp.ml. + * + * old: + * if Lexer_parser.is_typedef s + * then Ident_Typedef (s, info) + * else TIdent (s, info) + *) + | None -> TIdent (s, info) + ) + } + + (* gccext: apparently gcc allows dollar in variable names. I've found such + * things a few times in Linux and in glibc. + * No need to look in keyword_table here; definitly a TIdent. + *) + | (letter | '$') (letter | digit | '$')* + { + let s = tok lexbuf in + if not !Flag.sgrep_mode + then error ("identifier with dollar: " ^ s); + TIdent (s, tokinfo lexbuf) + } + + + (* ----------------------------------------------------------------------- *) + (* C constant *) + (* ----------------------------------------------------------------------- *) + + | "'" + { let info = tokinfo lexbuf in + let s = char lexbuf in + TChar ((s, IsChar), (info +> tok_add_s (s ^ "'"))) + } + | '"' + { let info = tokinfo lexbuf in + let s = string lexbuf in + TString ((s, IsChar), (info +> tok_add_s (s ^ "\""))) + } + (* wide character encoding, TODO L'toto' valid ? what is allowed ? *) + | 'L' "'" + { let info = tokinfo lexbuf in + let s = char lexbuf in + TChar ((s, IsWchar), (info +> tok_add_s (s ^ "'"))) + } + | 'L' '"' + { let info = tokinfo lexbuf in + let s = string lexbuf in + TString ((s, IsWchar), (info +> tok_add_s (s ^ "\""))) + } + + (* Take care of the order ? No because lex try the longest match. The + * strange diff between decimal and octal constant semantic is not + * understood too by refman :) refman:11.1.4, and ritchie. + *) + | (( decimal | hexa | octal) + ( ['u' 'U'] + | ['l' 'L'] + | (['l' 'L'] ['u' 'U']) + | (['u' 'U'] ['l' 'L']) + | (['u' 'U'] ['l' 'L'] ['l' 'L']) + | (['l' 'L'] ['l' 'L']) + )? + ) as x { TInt (x, tokinfo lexbuf) } + + | (real ['f' 'F']) as x { TFloat ((x, CFloat), tokinfo lexbuf) } + | (real ['l' 'L']) as x { TFloat ((x, CLongDouble), tokinfo lexbuf) } + | (real as x) { TFloat ((x, CDouble), tokinfo lexbuf) } + + | ['0'] ['0'-'9']+ + { error (error_radix "octal" ^ tok lexbuf); + TUnknown (tokinfo lexbuf) + } + | ("0x" |"0X") ['0'-'9' 'a'-'z' 'A'-'Z']+ + { error (error_radix "hexa" ^ tok lexbuf); + TUnknown (tokinfo lexbuf) + } + + (* !put after other rules! otherwise 0xff will be parsed as an ident *) + | ['0'-'9']+ letter (letter | digit) * + { error ("ZARB integer_string, certainly a macro:" ^ tok lexbuf); + TUnknown (tokinfo lexbuf) + } + +(* gccext: http://gcc.gnu.org/onlinedocs/gcc/Binary-constants.html *) +(* + | "0b" ['0'-'1'] { TInt (((tok lexbuf)(??,??)) +> int_of_stringbits) } + | ['0'-'1']+'b' { TInt (((tok lexbuf)(0,-2)) +> int_of_stringbits) } +*) + (*------------------------------------------------------------------------ *) + | eof { EOF (tokinfo lexbuf +> PI.rewrap_str "") } + + | _ { + error("unrecognised symbol, in token rule:" ^ tok lexbuf); + TUnknown (tokinfo lexbuf) + } + +(*****************************************************************************) +(* Rule char *) +(*****************************************************************************) +and char = parse +(* c++ext: or firefoxext: unicode char may take multiple char as in 'MOSS' + | (_ as x) "'" { String.make 1 x } + + (* todo?: as for octal, do exception beyond radix exception ? *) + | (("\\" (oct | oct oct | oct oct oct)) as x "'") { x } + (* this rule must be after the one with octal, lex try first longest + * and when \7 we want an octal, not an exn. + *) + | (("\\x" ((hex | hex hex))) as x "'") { x } + | (("\\" (_ as v)) as x "'") + { + (match v with (* Machine specific ? *) + | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> () | 'r' -> () + | 'f' -> () | 'a' -> () + | '\\' -> () | '?' -> () | '\'' -> () | '"' -> () + | 'e' -> () (* linuxext: ? *) + | _ -> + error ("unrecognised symbol in char:"^tok lexbuf); + ); + x + } + | _ + { error ("unrecognised symbol in char:"^tok lexbuf); + tok lexbuf + } +*) +(* c++ext: mostly copy paste of string but s/"/'/ " and s/string/char *) + | '\'' { "" } + | (_ as x) + { Common2.string_of_char x^char lexbuf} + + | ("\\" (oct | oct oct | oct oct oct)) as x { x ^ char lexbuf } + | ("\\x" (hex | hex hex)) as x { x ^ char lexbuf } + | ("\\" (_ as v)) as x + { + (match v with (* Machine specific ? *) + | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> () | 'r' -> () + | 'f' -> () | 'a' -> () + | '\\' -> () | '?' -> () | '\'' -> () | '"' -> () + | 'e' -> () (* linuxext: ? *) + + (* old: "x" -> 10 gccext ? todo ugly, I put a fake value *) + + (* cppext: can have \ for multiline in string too *) + | '\n' -> () + | _ -> error ("unrecognised symbol in char:"^tok lexbuf); + ); + x ^ char lexbuf + } + | eof { error "WEIRD end of file in char"; ""} + +(*****************************************************************************) +(* Rule string *) +(*****************************************************************************) +(* less? factorise code with char ? but not same ending token so hard. *) +and string = parse + | '"' { "" } + | (_ as x) + { Common2.string_of_char x^string lexbuf} + + | ("\\" (oct | oct oct | oct oct oct)) as x { x ^ string lexbuf } + | ("\\x" (hex | hex hex)) as x { x ^ string lexbuf } + (* unicode *) + | ("\\u" (hex hex hex hex)) as x { x ^ string lexbuf } + | ("\\U" (hex hex hex hex hex hex hex hex)) as x { x ^ string lexbuf } + | ("\\" (_ as v)) as x + { + (match v with (* Machine specific ? *) + | 'n' -> () | 't' -> () | 'v' -> () | 'b' -> () | 'r' -> () + | 'f' -> () | 'a' -> () + | '\\' -> () | '?' -> () | '\'' -> () | '"' -> () + | 'e' -> () (* linuxext: ? *) + + (* old: "x" -> 10 gccext ? todo ugly, I put a fake value *) + + (* cppext: can have \ for multiline in string too *) + | '\n' -> () + | _ -> error ("unrecognised symbol in string:"^tok lexbuf); + ); + x ^ string lexbuf + } + | eof { error "WEIRD end of file in string"; ""} + + (* Bug if add following code, cos match also the '"' that is needed + * to finish the string, and so go until end of file. + *) + (* + | [^ '\\']+ + { let cs = lexbuf +> tok +> list_of_string +> List.map Char.code in + cs ++ string lexbuf + } + *) + +(*****************************************************************************) +(* Rule comment *) +(*****************************************************************************) + +(* less: allow only char-'*' ? *) +and comment = parse + | "*/" { tok lexbuf } + (* noteopti: *) + | [^ '*']+ { let s = tok lexbuf in s ^ comment lexbuf } + | [ '*'] { let s = tok lexbuf in s ^ comment lexbuf } + | _ + { let s = tok lexbuf in + error ("unrecognised symbol in comment:"^s); + s ^ comment lexbuf + } + | eof { error "WEIRD end of file in comment"; ""} + +(*****************************************************************************) +(* Rule cpp_eat_until_nl *) +(*****************************************************************************) + +(* cpp recognize C comments, so when #define xx (yy) /* comment \n ... */ + * then he has already erased the /* comment. So: + * - dont eat the start of the comment otherwise afterwards we are in the middle + * of a comment and so we will problably get a parse error somewhere. + * - have to recognize comments in cpp_eat_until_nl. + * + * note: I was using cpp_eat_until_nl for #define before, but now I + * try also to parse define body so cpp_eat_until_nl is used only for the "body" + * of other uninteresting directtives like #ifdef, #else where can have + * stuff on the right on such directive. + *) +and cpp_eat_until_nl = parse + (* bugfix: need to handle comments too *) + | "/*" + { let s = tok lexbuf in + let s2 = comment lexbuf in + let s3 = cpp_eat_until_nl lexbuf in + s ^ s2 ^ s3 + } + | '\\' "\n" { let s = tok lexbuf in s ^ cpp_eat_until_nl lexbuf } + + | "\n" { tok lexbuf } + (* noteopti: + * update: need also deal with comments chars now + *) + | [^ '\n' '\\' '/' '*' ]+ + { let s = tok lexbuf in s ^ cpp_eat_until_nl lexbuf } + + | eof { error "end of file in cpp_eat_until_nl"; ""} + | _ { let s = tok lexbuf in s ^ cpp_eat_until_nl lexbuf } diff --git a/lang_cpp/parsing/lib_parsing_cpp.ml b/lang_cpp/parsing/lib_parsing_cpp.ml new file mode 100644 index 0000000..715f4c6 --- /dev/null +++ b/lang_cpp/parsing/lib_parsing_cpp.ml @@ -0,0 +1,49 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) +open Common + +module V = Visitor_cpp +module FT = File_type + +(*****************************************************************************) +(* Filemames *) +(*****************************************************************************) + +let find_source_files_of_dir_or_files xs = + Common.files_of_dir_or_files_no_vcs_nofilter xs + +> List.filter (fun filename -> + match File_type.file_type_of_file filename with + | FT.PL (FT.C ("l" | "y")) -> false + | FT.PL (FT.C _ | FT.Cplusplus _ ) -> + (* todo: fix syncweb so don't need this! *) + not (FT.is_syncweb_obj_file filename) + | _ -> false + + ) +> Common.sort + +(*****************************************************************************) +(* ii_of_any *) +(*****************************************************************************) + +let ii_of_any any = + let globals = ref [] in + let visitor = V.mk_visitor { V.default_visitor with + V.kinfo = (fun (_k,_) i -> Common.push i globals) + } + in + visitor any; + List.rev !globals + + diff --git a/lang_cpp/parsing/lib_parsing_cpp.mli b/lang_cpp/parsing/lib_parsing_cpp.mli new file mode 100644 index 0000000..a09ca77 --- /dev/null +++ b/lang_cpp/parsing/lib_parsing_cpp.mli @@ -0,0 +1,5 @@ + +val find_source_files_of_dir_or_files: + Common.path list -> Common.filename list + +val ii_of_any: Ast_cpp.any -> Parse_info.info list diff --git a/lang_cpp/parsing/license.txt b/lang_cpp/parsing/license.txt new file mode 100644 index 0000000..c443b8d --- /dev/null +++ b/lang_cpp/parsing/license.txt @@ -0,0 +1,341 @@ +GPL + + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/lang_cpp/parsing/meta_ast_cpp.ml b/lang_cpp/parsing/meta_ast_cpp.ml new file mode 100644 index 0000000..cfef14e --- /dev/null +++ b/lang_cpp/parsing/meta_ast_cpp.ml @@ -0,0 +1,1146 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) + +(* generated by ocamltarzan: ocamltarzan -choice vof ast_cpp.ml *) + +open Ast_cpp +module Ast = Ast_cpp +module M = Meta_ast_generic + +(* todo? could also do via a post processing phase with a OCaml.map_v ? *) +let _current_precision = ref M.default_precision + +let rec vof_info x = + if !_current_precision.M.full_info + then Parse_info.vof_info x + else if !_current_precision.M.token_info + then + Ocaml.VDict [ + "line", Ocaml.VInt (Parse_info.line_of_info x); + "col", Ocaml.VInt (Parse_info.col_of_info x); + ] + else Ocaml.VUnit + +and vof_tok v = vof_info v +and vof_wrap _of_a (v1, v2) = + let v1 = _of_a v1 + and v2 = Ocaml.vof_list vof_info v2 + in Ocaml.VTuple [ v1; v2 ] +and vof_wrap2 _of_a (v1, v2) = + let v1 = _of_a v1 and v2 = vof_info v2 in Ocaml.VTuple [ v1; v2 ] + +and vof_paren _of_a (v1, v2, v3) = + if !_current_precision.M.token_info then + let v1 = vof_tok v1 + and v2 = _of_a v2 + and v3 = vof_tok v3 + in Ocaml.VTuple [ v1; v2; v3 ] + else _of_a v2 +and vof_brace _of_a (v1, v2, v3) = + if !_current_precision.M.token_info then + let v1 = vof_tok v1 + and v2 = _of_a v2 + and v3 = vof_tok v3 + in Ocaml.VTuple [ v1; v2; v3 ] + else _of_a v2 +and vof_bracket _of_a (v1, v2, v3) = + if !_current_precision.M.token_info then + let v1 = vof_tok v1 + and v2 = _of_a v2 + and v3 = vof_tok v3 + in Ocaml.VTuple [ v1; v2; v3 ] + else _of_a v2 +and vof_angle _of_a (v1, v2, v3) = + let v1 = vof_tok v1 + and v2 = _of_a v2 + and v3 = vof_tok v3 + in Ocaml.VTuple [ v1; v2; v3 ] + +and vof_comma_list _of_a xs= + if !_current_precision.M.token_info + then Ocaml.vof_list (vof_wrap _of_a) xs + else Ocaml.vof_list _of_a (Ast.uncomma xs) + +and vof_comma_list2 _of_a = Ocaml.vof_list (Ocaml.vof_either _of_a vof_tok) + + +let rec vof_name (v1, v2, v3) = + let v1 = Ocaml.vof_option vof_tok v1 + and v2 = + Ocaml.vof_list + (fun (v1, v2) -> + let v1 = vof_qualifier v1 + and v2 = vof_tok v2 + in Ocaml.VTuple [ v1; v2 ]) + v2 + and v3 = vof_ident v3 + in Ocaml.VTuple [ v1; v2; v3 ] +and vof_ident = + function + | IdIdent v1 -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + in Ocaml.VSum (("IdIdent", [ v1 ])) + | IdOperator ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = + (match v2 with + | (v1, v2) -> + let v1 = vof_operator v1 + and v2 = Ocaml.vof_list vof_tok v2 + in Ocaml.VTuple [ v1; v2 ]) + in Ocaml.VSum (("IdOperator", [ v1; v2 ])) + | IdConverter ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_fullType v2 + in Ocaml.VSum (("IdConverter", [ v1; v2 ])) + | IdDestructor ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + in Ocaml.VSum (("IdDestructor", [ v1; v2 ])) + | IdTemplateId ((v1, v2)) -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + and v2 = vof_template_arguments v2 + in Ocaml.VSum (("IdTemplateId", [ v1; v2 ])) +and vof_template_arguments v = + vof_angle (vof_comma_list vof_template_argument) v +and vof_template_argument v = Ocaml.vof_either vof_fullType vof_expression v +and vof_qualifier = + function + | QClassname v1 -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + in Ocaml.VSum (("QClassname", [ v1 ])) + | QTemplateId ((v1, v2)) -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + and v2 = vof_template_arguments v2 + in Ocaml.VSum (("QTemplateId", [ v1; v2 ])) +and vof_class_name v = vof_name v +and vof_namespace_name v = vof_name v +and vof_ident_name v = vof_name v + +and vof_either_ft_or_expr v = Ocaml.vof_either vof_fullType vof_expression v + + +and vof_fullType (v1, v2) = + let v1 = vof_typeQualifier v1 + and v2 = vof_typeC v2 + in Ocaml.VTuple [ v1; v2 ] +and vof_typeC v = vof_wrap vof_typeCbis v +and vof_typeCbis = + function + | BaseType v1 -> + let v1 = vof_baseType v1 in Ocaml.VSum (("BaseType", [ v1 ])) + | Pointer v1 -> + let v1 = vof_fullType v1 in Ocaml.VSum (("Pointer", [ v1 ])) + | Reference v1 -> + let v1 = vof_fullType v1 in Ocaml.VSum (("Reference", [ v1 ])) + | Array ((v1, v2)) -> + let v1 = vof_bracket (Ocaml.vof_option vof_constExpression) v1 + and v2 = vof_fullType v2 + in Ocaml.VSum (("Array", [ v1; v2 ])) + | FunctionType v1 -> + let v1 = vof_functionType v1 in Ocaml.VSum (("FunctionType", [ v1 ])) + | EnumDef ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = Ocaml.vof_option (vof_wrap2 Ocaml.vof_string) v2 + and v3 = vof_brace (vof_comma_list vof_enum_elem) v3 + in Ocaml.VSum (("EnumDed", [ v1; v2; v3 ])) + | StructDef v1 -> + let v1 = vof_class_definition v1 + in Ocaml.VSum (("StructDef", [ v1 ])) + | EnumName ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + in Ocaml.VSum (("EnumName", [ v1; v2 ])) + | StructUnionName ((v1, v2)) -> + let v1 = vof_wrap2 vof_structUnion v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + in Ocaml.VSum (("StructUnionName", [ v1; v2 ])) + | TypeName ((v1)) -> + let v1 = vof_name v1 + in Ocaml.VSum (("TypeName", [ v1 ])) + | TypenameKwd ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_name v2 + in Ocaml.VSum (("TypenameKwd", [ v1; v2 ])) + | TypeOf ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_paren vof_either_ft_or_expr v2 + in Ocaml.VSum (("TypeOf", [ v1; v2 ])) + | ParenType v1 -> + let v1 = vof_paren vof_fullType v1 + in Ocaml.VSum (("ParenType", [ v1 ])) +and vof_baseType = + function + | Void -> Ocaml.VSum (("Void", [])) + | IntType v1 -> let v1 = vof_intType v1 in Ocaml.VSum (("IntType", [ v1 ])) + | FloatType v1 -> + let v1 = vof_floatType v1 in Ocaml.VSum (("FloatType", [ v1 ])) +and vof_intType = + function + | CChar -> Ocaml.VSum (("CChar", [])) + | Si v1 -> let v1 = vof_signed v1 in Ocaml.VSum (("Si", [ v1 ])) + | CBool -> Ocaml.VSum (("CBool", [])) + | WChar_t -> Ocaml.VSum (("WChar_t", [])) +and vof_signed (v1, v2) = + let v1 = vof_sign v1 and v2 = vof_base v2 in Ocaml.VTuple [ v1; v2 ] +and vof_base = + function + | CChar2 -> Ocaml.VSum (("CChar2", [])) + | CShort -> Ocaml.VSum (("CShort", [])) + | CInt -> Ocaml.VSum (("CInt", [])) + | CLong -> Ocaml.VSum (("CLong", [])) + | CLongLong -> Ocaml.VSum (("CLongLong", [])) +and vof_sign = + function + | Signed -> Ocaml.VSum (("Signed", [])) + | UnSigned -> Ocaml.VSum (("UnSigned", [])) +and vof_floatType = + function + | CFloat -> Ocaml.VSum (("CFloat", [])) + | CDouble -> Ocaml.VSum (("CDouble", [])) + | CLongDouble -> Ocaml.VSum (("CLongDouble", [])) +and vof_enum_elem { e_name = v_e_name; e_val = v_e_val } = + let bnds = [] in + let arg = + Ocaml.vof_option + (fun (v1, v2) -> + let v1 = vof_tok v1 + and v2 = vof_constExpression v2 + in Ocaml.VTuple [ v1; v2 ]) + v_e_val in + let bnd = ("e_val", arg) in + let bnds = bnd :: bnds in + let arg = vof_wrap2 Ocaml.vof_string v_e_name in + let bnd = ("e_name", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds + + +and vof_typeQualifier { const = v_const; volatile = v_volatile } = + if not !_current_precision.M.type_info + then Ocaml.VUnit + else + let bnds = [] in + let arg = Ocaml.vof_option vof_tok v_volatile in + let bnd = ("volatile", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_option vof_tok v_const in + let bnd = ("const", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds + +and vof_expression v = vof_wrap vof_expressionbis v +and vof_expressionbis = + function + | Id ((v1, v2)) -> + let v1 = vof_name v1 + and v2 = vof_ident_info v2 + in Ocaml.VSum (("Id", [ v1; v2 ])) + | C v1 -> let v1 = vof_constant v1 in Ocaml.VSum (("C", [ v1 ])) + | Call ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_paren (vof_comma_list vof_argument) v2 + in Ocaml.VSum (("Call", [ v1; v2 ])) + | CondExpr ((v1, v2, v3)) -> + let v1 = vof_expression v1 + and v2 = Ocaml.vof_option vof_expression v2 + and v3 = vof_expression v3 + in Ocaml.VSum (("CondExpr", [ v1; v2; v3 ])) + | Sequence ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("Sequence", [ v1; v2 ])) + | Assignment ((v1, v2, v3)) -> + let v1 = vof_expression v1 + and v2 = vof_assignOp v2 + and v3 = vof_expression v3 + in Ocaml.VSum (("Assignment", [ v1; v2; v3 ])) + | Postfix ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_fixOp v2 + in Ocaml.VSum (("Postfix", [ v1; v2 ])) + | Infix ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_fixOp v2 + in Ocaml.VSum (("Infix", [ v1; v2 ])) + | Unary ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_unaryOp v2 + in Ocaml.VSum (("Unary", [ v1; v2 ])) + | Binary ((v1, v2, v3)) -> + let v1 = vof_expression v1 + and v2 = vof_binaryOp v2 + and v3 = vof_expression v3 + in Ocaml.VSum (("Binary", [ v1; v2; v3 ])) + | ArrayAccess ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_bracket vof_expression v2 + in Ocaml.VSum (("ArrayAccess", [ v1; v2 ])) + | RecordAccess ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_name v2 + in Ocaml.VSum (("RecordAccess", [ v1; v2 ])) + | RecordPtAccess ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_name v2 + in Ocaml.VSum (("RecordPtAccess", [ v1; v2 ])) + | RecordStarAccess ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("RecordStarAccess", [ v1; v2 ])) + | RecordPtStarAccess ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("RecordPtStarAccess", [ v1; v2 ])) + | SizeOfExpr ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("SizeOfExpr", [ v1; v2 ])) + | SizeOfType ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_paren vof_fullType v2 + in Ocaml.VSum (("SizeOfType", [ v1; v2 ])) + | Cast ((v1, v2)) -> + let v1 = vof_paren vof_fullType v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("Cast", [ v1; v2 ])) + | StatementExpr v1 -> + let v1 = vof_paren vof_compound v1 + in Ocaml.VSum (("StatementExpr", [ v1 ])) + | GccConstructor ((v1, v2)) -> + let v1 = vof_paren vof_fullType v1 + and v2 = vof_brace (vof_comma_list vof_initialiser) v2 + in Ocaml.VSum (("GccConstructor", [ v1; v2 ])) + | This v1 -> let v1 = vof_tok v1 in Ocaml.VSum (("This", [ v1 ])) + | ConstructedObject ((v1, v2)) -> + let v1 = vof_fullType v1 + and v2 = vof_paren (vof_comma_list vof_argument) v2 + in Ocaml.VSum (("ConstructedObject", [ v1; v2 ])) + | TypeId ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_paren vof_either_ft_or_expr v2 + in Ocaml.VSum (("TypeId", [ v1; v2 ])) + | CplusplusCast ((v1, v2, v3)) -> + let v1 = vof_wrap2 vof_cast_operator v1 + and v2 = vof_angle vof_fullType v2 + and v3 = vof_paren vof_expression v3 + in Ocaml.VSum (("CplusplusCast", [ v1; v2; v3 ])) + | New ((v1, v2, v3, v4, v5)) -> + let v1 = Ocaml.vof_option vof_tok v1 + and v2 = vof_tok v2 + and v3 = Ocaml.vof_option (vof_paren (vof_comma_list vof_argument)) v3 + and v4 = vof_fullType v4 + and v5 = Ocaml.vof_option (vof_paren (vof_comma_list vof_argument)) v5 + in Ocaml.VSum (("New", [ v1; v2; v3; v4; v5 ])) + | Delete ((v1, v2)) -> + let v1 = Ocaml.vof_option vof_tok v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("Delete", [ v1; v2 ])) + | DeleteArray ((v1, v2)) -> + let v1 = Ocaml.vof_option vof_tok v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("DeleteArray", [ v1; v2 ])) + | Throw v1 -> + let v1 = Ocaml.vof_option vof_expression v1 + in Ocaml.VSum (("Throw", [ v1 ])) + | ParenExpr v1 -> + let v1 = vof_paren vof_expression v1 + in Ocaml.VSum (("ParenExpr", [ v1 ])) + | ExprTodo -> Ocaml.VSum (("ExprTodo", [])) +and vof_ident_info { i_scope = v_i_scope } = + let bnds = [] in + let arg = Scope_code.vof_scope v_i_scope in + let bnd = ("i_scope", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and vof_argument v = Ocaml.vof_either vof_expression vof_weird_argument v +and vof_weird_argument = + function + | ArgType v1 -> + let v1 = vof_fullType v1 in Ocaml.VSum (("ArgType", [ v1 ])) + | ArgAction v1 -> + let v1 = vof_action_macro v1 in Ocaml.VSum (("ArgAction", [ v1 ])) +and vof_action_macro = + function + | ActMisc v1 -> + let v1 = Ocaml.vof_list vof_tok v1 in Ocaml.VSum (("ActMisc", [ v1 ])) +and vof_constant = + function + | String v1 -> + let v1 = + (match v1 with + | (v1, v2) -> + let v1 = Ocaml.vof_string v1 + and v2 = vof_isWchar v2 + in Ocaml.VTuple [ v1; v2 ]) + in Ocaml.VSum (("String", [ v1 ])) + | MultiString -> Ocaml.VSum (("MultiString", [])) + | Char v1 -> + let v1 = + (match v1 with + | (v1, v2) -> + let v1 = Ocaml.vof_string v1 + and v2 = vof_isWchar v2 + in Ocaml.VTuple [ v1; v2 ]) + in Ocaml.VSum (("Char", [ v1 ])) + | Int v1 -> let v1 = Ocaml.vof_string v1 in Ocaml.VSum (("Int", [ v1 ])) + | Float v1 -> + let v1 = + (match v1 with + | (v1, v2) -> + let v1 = Ocaml.vof_string v1 + and v2 = vof_floatType v2 + in Ocaml.VTuple [ v1; v2 ]) + in Ocaml.VSum (("Float", [ v1 ])) + | Bool v1 -> let v1 = Ocaml.vof_bool v1 in Ocaml.VSum (("Bool", [ v1 ])) +and vof_isWchar = + function + | IsWchar -> Ocaml.VSum (("IsWchar", [])) + | IsChar -> Ocaml.VSum (("IsChar", [])) +and vof_unaryOp = + function + | GetRef -> Ocaml.VSum (("GetRef", [])) + | DeRef -> Ocaml.VSum (("DeRef", [])) + | UnPlus -> Ocaml.VSum (("UnPlus", [])) + | UnMinus -> Ocaml.VSum (("UnMinus", [])) + | Tilde -> Ocaml.VSum (("Tilde", [])) + | Not -> Ocaml.VSum (("Not", [])) + | GetRefLabel -> Ocaml.VSum (("GetRefLabel", [])) +and vof_assignOp = + function + | SimpleAssign -> Ocaml.VSum (("SimpleAssign", [])) + | OpAssign v1 -> + let v1 = vof_arithOp v1 in Ocaml.VSum (("OpAssign", [ v1 ])) +and vof_fixOp = + function + | Dec -> Ocaml.VSum (("Dec", [])) + | Inc -> Ocaml.VSum (("Inc", [])) +and vof_binaryOp = + function + | Arith v1 -> let v1 = vof_arithOp v1 in Ocaml.VSum (("Arith", [ v1 ])) + | Logical v1 -> + let v1 = vof_logicalOp v1 in Ocaml.VSum (("Logical", [ v1 ])) +and vof_arithOp = + function + | Plus -> Ocaml.VSum (("Plus", [])) + | Minus -> Ocaml.VSum (("Minus", [])) + | Mul -> Ocaml.VSum (("Mul", [])) + | Div -> Ocaml.VSum (("Div", [])) + | Mod -> Ocaml.VSum (("Mod", [])) + | DecLeft -> Ocaml.VSum (("DecLeft", [])) + | DecRight -> Ocaml.VSum (("DecRight", [])) + | And -> Ocaml.VSum (("And", [])) + | Or -> Ocaml.VSum (("Or", [])) + | Xor -> Ocaml.VSum (("Xor", [])) +and vof_logicalOp = + function + | Inf -> Ocaml.VSum (("Inf", [])) + | Sup -> Ocaml.VSum (("Sup", [])) + | InfEq -> Ocaml.VSum (("InfEq", [])) + | SupEq -> Ocaml.VSum (("SupEq", [])) + | Eq -> Ocaml.VSum (("Eq", [])) + | NotEq -> Ocaml.VSum (("NotEq", [])) + | AndLog -> Ocaml.VSum (("AndLog", [])) + | OrLog -> Ocaml.VSum (("OrLog", [])) +and vof_ptrOp = + function + | PtrStarOp -> Ocaml.VSum (("PtrStarOp", [])) + | PtrOp -> Ocaml.VSum (("PtrOp", [])) +and vof_allocOp = + function + | NewOp -> Ocaml.VSum (("NewOp", [])) + | DeleteOp -> Ocaml.VSum (("DeleteOp", [])) + | NewArrayOp -> Ocaml.VSum (("NewArrayOp", [])) + | DeleteArrayOp -> Ocaml.VSum (("DeleteArrayOp", [])) +and vof_accessop = + function + | ParenOp -> Ocaml.VSum (("ParenOp", [])) + | ArrayOp -> Ocaml.VSum (("ArrayOp", [])) +and vof_operator = + function + | BinaryOp v1 -> + let v1 = vof_binaryOp v1 in Ocaml.VSum (("BinaryOp", [ v1 ])) + | AssignOp v1 -> + let v1 = vof_assignOp v1 in Ocaml.VSum (("AssignOp", [ v1 ])) + | FixOp v1 -> let v1 = vof_fixOp v1 in Ocaml.VSum (("FixOp", [ v1 ])) + | PtrOpOp v1 -> let v1 = vof_ptrOp v1 in Ocaml.VSum (("PtrOpOp", [ v1 ])) + | AccessOp v1 -> + let v1 = vof_accessop v1 in Ocaml.VSum (("AccessOp", [ v1 ])) + | AllocOp v1 -> let v1 = vof_allocOp v1 in Ocaml.VSum (("AllocOp", [ v1 ])) + | UnaryTildeOp -> Ocaml.VSum (("UnaryTildeOp", [])) + | UnaryNotOp -> Ocaml.VSum (("UnaryNotOp", [])) + | CommaOp -> Ocaml.VSum (("CommaOp", [])) +and vof_cast_operator = + function + | Static_cast -> Ocaml.VSum (("Static_cast", [])) + | Dynamic_cast -> Ocaml.VSum (("Dynamic_cast", [])) + | Const_cast -> Ocaml.VSum (("Const_cast", [])) + | Reinterpret_cast -> Ocaml.VSum (("Reinterpret_cast", [])) +and vof_constExpression v = vof_expression v +and vof_statement v = vof_wrap vof_statementbis v +and vof_statementbis = + function + | Compound v1 -> + let v1 = vof_compound v1 in Ocaml.VSum (("Compound", [ v1 ])) + | ExprStatement v1 -> + let v1 = vof_exprStatement v1 in Ocaml.VSum (("ExprStatement", [ v1 ])) + | Labeled v1 -> let v1 = vof_labeled v1 in Ocaml.VSum (("Labeled", [ v1 ])) + | Selection v1 -> + let v1 = vof_selection v1 in Ocaml.VSum (("Selection", [ v1 ])) + | Iteration v1 -> + let v1 = vof_iteration v1 in Ocaml.VSum (("Iteration", [ v1 ])) + | Jump v1 -> let v1 = vof_jump v1 in Ocaml.VSum (("Jump", [ v1 ])) + | DeclStmt v1 -> + let v1 = vof_block_declaration v1 in Ocaml.VSum (("DeclStmt", [ v1 ])) + | Try ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_compound v2 + and v3 = Ocaml.vof_list vof_handler v3 + in Ocaml.VSum (("Try", [ v1; v2; v3 ])) + | NestedFunc v1 -> + let v1 = vof_func_definition v1 in Ocaml.VSum (("NestedFunc", [ v1 ])) + | MacroStmt -> Ocaml.VSum (("MacroStmt", [])) + | StmtTodo -> Ocaml.VSum (("StmtTodo", [])) +and vof_compound v = vof_brace (Ocaml.vof_list vof_statement_sequencable) v +and vof_statement_sequencable = + function + | StmtElem v1 -> + let v1 = vof_statement v1 in Ocaml.VSum (("StmtElem", [ v1 ])) + | CppDirectiveStmt v1 -> + let v1 = vof_cpp_directive v1 + in Ocaml.VSum (("CppDirectiveStmt", [ v1 ])) + | IfdefStmt v1 -> + let v1 = vof_ifdef_directive v1 in Ocaml.VSum (("IfdefStmt", [ v1 ])) +and vof_exprStatement v = Ocaml.vof_option vof_expression v +and vof_labeled = + function + | Label ((v1, v2)) -> + let v1 = Ocaml.vof_string v1 + and v2 = vof_statement v2 + in Ocaml.VSum (("Label", [ v1; v2 ])) + | Case ((v1, v2)) -> + let v1 = vof_expression v1 + and v2 = vof_statement v2 + in Ocaml.VSum (("Case", [ v1; v2 ])) + | CaseRange ((v1, v2, v3)) -> + let v1 = vof_expression v1 + and v2 = vof_expression v2 + and v3 = vof_statement v3 + in Ocaml.VSum (("CaseRange", [ v1; v2; v3 ])) + | Default v1 -> + let v1 = vof_statement v1 in Ocaml.VSum (("Default", [ v1 ])) +and vof_selection = + function + | If ((v1, v2, v3, v4, v5)) -> + let v1 = vof_tok v1 + and v2 = vof_paren vof_expression v2 + and v3 = vof_statement v3 + and v4 = Ocaml.vof_option vof_tok v4 + and v5 = vof_statement v5 + in Ocaml.VSum (("If", [ v1; v2; v3; v4; v5 ])) + | Switch ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_paren vof_expression v2 + and v3 = vof_statement v3 + in Ocaml.VSum (("Switch", [ v1; v2; v3 ])) +and vof_iteration = + function + | While ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_paren vof_expression v2 + and v3 = vof_statement v3 + in Ocaml.VSum (("While", [ v1; v2; v3 ])) + | DoWhile ((v1, v2, v3, v4, v5)) -> + let v1 = vof_tok v1 + and v2 = vof_statement v2 + and v3 = vof_tok v3 + and v4 = vof_paren vof_expression v4 + and v5 = vof_tok v5 + in Ocaml.VSum (("DoWhile", [ v1; v2; v3; v4; v5 ])) + | For ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = + vof_paren + (fun (v1, v2, v3) -> + let v1 = vof_wrap vof_exprStatement v1 + and v2 = vof_wrap vof_exprStatement v2 + and v3 = vof_wrap vof_exprStatement v3 + in Ocaml.VTuple [ v1; v2; v3 ]) + v2 + and v3 = vof_statement v3 + in Ocaml.VSum (("For", [ v1; v2; v3 ])) + | MacroIteration ((v1, v2, v3)) -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + and v2 = vof_paren (vof_comma_list vof_argument) v2 + and v3 = vof_statement v3 + in Ocaml.VSum (("MacroIteration", [ v1; v2; v3 ])) +and vof_jump = + function + | Goto v1 -> let v1 = Ocaml.vof_string v1 in Ocaml.VSum (("Goto", [ v1 ])) + | Continue -> Ocaml.VSum (("Continue", [])) + | Break -> Ocaml.VSum (("Break", [])) + | Return -> Ocaml.VSum (("Return", [])) + | ReturnExpr v1 -> + let v1 = vof_expression v1 in Ocaml.VSum (("ReturnExpr", [ v1 ])) + | GotoComputed v1 -> + let v1 = vof_expression v1 in Ocaml.VSum (("GotoComputed", [ v1 ])) +and vof_handler (v1, v2, v3) = + let v1 = vof_tok v1 + and v2 = vof_paren vof_exception_declaration v2 + and v3 = vof_compound v3 + in Ocaml.VTuple [ v1; v2; v3 ] +and vof_exception_declaration = + function + | ExnDeclEllipsis v1 -> + let v1 = vof_tok v1 in Ocaml.VSum (("ExnDeclEllipsis", [ v1 ])) + | ExnDecl v1 -> + let v1 = vof_parameter v1 in Ocaml.VSum (("ExnDecl", [ v1 ])) +and vof_block_declaration = + function + | DeclList ((v1, v2)) -> + let v1 = vof_comma_list vof_onedecl v1 + and v2 = vof_tok v2 + in Ocaml.VSum (("DeclList", [ v1; v2 ])) + | MacroDecl ((v1, v2, v3, v4)) -> + let v1 = Ocaml.vof_list vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + and v3 = vof_paren (vof_comma_list vof_argument) v3 + and v4 = vof_tok v4 + in Ocaml.VSum (("MacroDecl", [ v1; v2; v3; v4 ])) + | UsingDecl v1 -> + let v1 = + (match v1 with + | (v1, v2, v3) -> + let v1 = vof_tok v1 + and v2 = vof_name v2 + and v3 = vof_tok v3 + in Ocaml.VTuple [ v1; v2; v3 ]) + in Ocaml.VSum (("UsingDecl", [ v1 ])) + | UsingDirective ((v1, v2, v3, v4)) -> + let v1 = vof_tok v1 + and v2 = vof_tok v2 + and v3 = vof_namespace_name v3 + and v4 = vof_tok v4 + in Ocaml.VSum (("UsingDirective", [ v1; v2; v3; v4 ])) + | NameSpaceAlias ((v1, v2, v3, v4, v5)) -> + let v1 = vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + and v3 = vof_tok v3 + and v4 = vof_namespace_name v4 + and v5 = vof_tok v5 + in Ocaml.VSum (("NameSpaceAlias", [ v1; v2; v3; v4; v5 ])) + | Asm ((v1, v2, v3, v4)) -> + let v1 = vof_tok v1 + and v2 = Ocaml.vof_option vof_tok v2 + and v3 = vof_paren vof_asmbody v3 + and v4 = vof_tok v4 + in Ocaml.VSum (("Asm", [ v1; v2; v3; v4 ])) +and + vof_onedecl { + v_namei = v_v_namei; + v_type = v_v_type; + v_storage = v_v_storage + } = + let bnds = [] in + let arg = vof_storage v_v_storage in + let bnd = ("v_storage", arg) in + let bnds = bnd :: bnds in + let arg = vof_fullType v_v_type in + let bnd = ("v_type", arg) in + let bnds = bnd :: bnds in + let arg = + Ocaml.vof_option + (fun (v1, v2) -> + let v1 = vof_name v1 + and v2 = Ocaml.vof_option vof_init v2 + in Ocaml.VTuple [ v1; v2 ]) + v_v_namei in + let bnd = ("v_namei", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and vof_storage v = vof_storagebis v +and vof_storagebis = + function + | NoSto -> Ocaml.VSum (("NoSto", [])) + | StoTypedef v1 -> + let v1 = vof_tok v1 in + Ocaml.VSum (("StoTypedef", [v1])) + | Sto v1 -> let v1 = vof_wrap2 vof_storageClass v1 in Ocaml.VSum (("Sto", [ v1 ])) +and vof_storageClass = + function + | Auto -> Ocaml.VSum (("Auto", [])) + | Static -> Ocaml.VSum (("Static", [])) + | Register -> Ocaml.VSum (("Register", [])) + | Extern -> Ocaml.VSum (("Extern", [])) +and vof_init = + function + | EqInit ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_initialiser v2 + in Ocaml.VSum (("EqInit", [ v1; v2 ])) + | ObjInit v1 -> + let v1 = vof_paren (vof_comma_list vof_argument) v1 + in Ocaml.VSum (("ObjInit", [ v1 ])) +and vof_initialiser = + function + | InitExpr v1 -> + let v1 = vof_expression v1 in Ocaml.VSum (("InitExpr", [ v1 ])) + | InitList v1 -> + let v1 = vof_brace (vof_comma_list vof_initialiser) v1 + in Ocaml.VSum (("InitList", [ v1 ])) + | InitDesignators ((v1, v2, v3)) -> + let v1 = Ocaml.vof_list vof_designator v1 + and v2 = vof_tok v2 + and v3 = vof_initialiser v3 + in Ocaml.VSum (("InitDesignators", [ v1; v2; v3 ])) + | InitFieldOld ((v1, v2, v3)) -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + and v2 = vof_tok v2 + and v3 = vof_initialiser v3 + in Ocaml.VSum (("InitFieldOld", [ v1; v2; v3 ])) + | InitIndexOld ((v1, v2)) -> + let v1 = vof_bracket vof_expression v1 + and v2 = vof_initialiser v2 + in Ocaml.VSum (("InitIndexOld", [ v1; v2 ])) +and vof_designator = + function + | DesignatorField ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + in Ocaml.VSum (("DesignatorField", [ v1; v2 ])) + | DesignatorIndex v1 -> + let v1 = vof_bracket vof_expression v1 + in Ocaml.VSum (("DesignatorIndex", [ v1 ])) + | DesignatorRange v1 -> + let v1 = + vof_bracket + (fun (v1, v2, v3) -> + let v1 = vof_expression v1 + and v2 = vof_tok v2 + and v3 = vof_expression v3 + in Ocaml.VTuple [ v1; v2; v3 ]) + v1 + in Ocaml.VSum (("DesignatorRange", [ v1 ])) +and vof_asmbody (v1, v2) = + let v1 = Ocaml.vof_list vof_tok v1 + and v2 = Ocaml.vof_list (vof_wrap vof_colon) v2 + in Ocaml.VTuple [ v1; v2 ] +and vof_colon = + function + | Colon v1 -> + let v1 = vof_comma_list vof_colon_option v1 + in Ocaml.VSum (("Colon", [ v1 ])) +and vof_colon_option v = vof_wrap vof_colon_optionbis v +and vof_colon_optionbis = + function + | ColonMisc -> Ocaml.VSum (("ColonMisc", [])) + | ColonExpr v1 -> + let v1 = vof_paren vof_expression v1 + in Ocaml.VSum (("ColonExpr", [ v1 ])) +and + vof_func_definition { + f_name = v_f_name; + f_type = v_f_type; + f_storage = v_f_storage; + f_body = v_f_body + } = + let bnds = [] in + let arg = vof_compound v_f_body in + let bnd = ("f_body", arg) in + let bnds = bnd :: bnds in + let arg = vof_storage v_f_storage in + let bnd = ("f_storage", arg) in + let bnds = bnd :: bnds in + let arg = vof_functionType v_f_type in + let bnd = ("f_type", arg) in + let bnds = bnd :: bnds in + let arg = vof_name v_f_name in + let bnd = ("f_name", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and + vof_functionType { + ft_ret = v_ft_ret; + ft_params = v_ft_params; + ft_dots = v_ft_dots; + ft_const = v_ft_const; + ft_throw = v_ft_throw + } = + let bnds = [] in + let arg = Ocaml.vof_option vof_exn_spec v_ft_throw in + let bnd = ("ft_throw", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_option vof_tok v_ft_const in + let bnd = ("ft_const", arg) in + let bnds = bnd :: bnds in + let arg = + Ocaml.vof_option + (fun (v1, v2) -> + let v1 = vof_tok v1 and v2 = vof_tok v2 in Ocaml.VTuple [ v1; v2 ]) + v_ft_dots in + let bnd = ("ft_dots", arg) in + let bnds = bnd :: bnds in + let arg = vof_paren (vof_comma_list vof_parameter) v_ft_params in + let bnd = ("ft_params", arg) in + let bnds = bnd :: bnds in + let arg = vof_fullType v_ft_ret in + let bnd = ("ft_ret", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and + vof_parameter { + p_name = v_p_name; + p_type = v_p_type; + p_register = v_p_register; + p_val = v_p_val + } = + let bnds = [] in + let arg = + Ocaml.vof_option + (fun (v1, v2) -> + let v1 = vof_tok v1 + and v2 = vof_expression v2 + in Ocaml.VTuple [ v1; v2 ]) + v_p_val in + let bnd = ("p_val", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_option vof_tok v_p_register in + let bnd = ("p_register", arg) in + let bnds = bnd :: bnds in + let arg = vof_fullType v_p_type in + let bnd = ("p_type", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_option (vof_wrap2 Ocaml.vof_string) v_p_name in + let bnd = ("p_name", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and vof_func_or_else = + function + | FunctionOrMethod v1 -> + let v1 = vof_func_definition v1 + in Ocaml.VSum (("FunctionOrMethod", [ v1 ])) + | Constructor ((v1)) -> + let v1 = vof_func_definition v1 + in Ocaml.VSum (("Constructor", [ v1 ])) + | Destructor v1 -> + let v1 = vof_func_definition v1 in Ocaml.VSum (("Destructor", [ v1 ])) +and vof_exn_spec (v1, v2) = + let v1 = vof_tok v1 + and v2 = vof_paren (vof_comma_list2 vof_name) v2 + in Ocaml.VTuple [ v1; v2 ] + +and + vof_class_definition { + c_kind = v_c_kind; + c_name = v_c_name; + c_inherit = v_c_inherit; + c_members = v_c_members + } = + let bnds = [] in + let arg = + vof_brace (Ocaml.vof_list vof_class_member_sequencable) v_c_members in + let bnd = ("c_members", arg) in + let bnds = bnd :: bnds in + let arg = + Ocaml.vof_option + (fun (v1, v2) -> + let v1 = vof_tok v1 + and v2 = vof_comma_list vof_base_clause v2 + in Ocaml.VTuple [ v1; v2 ]) + v_c_inherit in + let bnd = ("c_inherit", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_option vof_ident_name v_c_name in + let bnd = ("c_name", arg) in + let bnds = bnd :: bnds in + let arg = vof_wrap2 vof_structUnion v_c_kind in + let bnd = ("c_kind", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and vof_structUnion = + function + | Struct -> Ocaml.VSum (("Struct", [])) + | Union -> Ocaml.VSum (("Union", [])) + | Class -> Ocaml.VSum (("Class", [])) +and + vof_base_clause { + i_name = v_i_name; + i_virtual = v_i_virtual; + i_access = v_i_access + } = + let bnds = [] in + let arg = Ocaml.vof_option (vof_wrap2 vof_access_spec) v_i_access in + let bnd = ("i_access", arg) in + let bnds = bnd :: bnds in + let arg = Ocaml.vof_option vof_tok v_i_virtual in + let bnd = ("i_virtual", arg) in + let bnds = bnd :: bnds in + let arg = vof_class_name v_i_name in + let bnd = ("i_name", arg) in let bnds = bnd :: bnds in Ocaml.VDict bnds +and vof_access_spec = + function + | Public -> Ocaml.VSum (("Public", [])) + | Private -> Ocaml.VSum (("Private", [])) + | Protected -> Ocaml.VSum (("Protected", [])) + +and vof_method_decl = function + | ConstructorDecl ((v1, v2, v3)) -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + and v2 = vof_paren (vof_comma_list vof_parameter) v2 + and v3 = vof_tok v3 + in Ocaml.VSum (("ConstructorDecl", [ v1; v2; v3 ])) + | DestructorDecl ((v1, v2, v3, v4, v5)) -> + let v1 = vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + and v3 = vof_paren (Ocaml.vof_option vof_tok) v3 + and v4 = Ocaml.vof_option vof_exn_spec v4 + and v5 = vof_tok v5 + in Ocaml.VSum (("DestructorDecl", [ v1; v2; v3; v4; v5 ])) + | MethodDecl ((v1, v2, v3)) -> + let v1 = vof_onedecl v1 + and v2 = + Ocaml.vof_option + (fun (v1, v2) -> + let v1 = vof_tok v1 + and v2 = vof_tok v2 + in Ocaml.VTuple [ v1; v2 ]) + v2 + and v3 = vof_tok v3 + in Ocaml.VSum (("MethodDecl", [ v1; v2; v3 ])) + +and vof_class_member = + function + | Access ((v1, v2)) -> + let v1 = vof_wrap2 vof_access_spec v1 + and v2 = vof_tok v2 + in Ocaml.VSum (("Access", [ v1; v2 ])) + | MemberField (v1, v2) -> + let v1 = (vof_comma_list vof_fieldkind) v1 + and v2 = vof_tok v2 + in Ocaml.VSum (("MemberField", [ v1; v2 ])) + | MemberFunc v1 -> + let v1 = vof_func_or_else v1 in Ocaml.VSum (("MemberFunc", [ v1 ])) + | MemberDecl v1 -> + let v1 = vof_method_decl v1 in + Ocaml.VSum (("MemberDecl", [ v1 ])) + | QualifiedIdInClass ((v1, v2)) -> + let v1 = vof_name v1 + and v2 = vof_tok v2 + in Ocaml.VSum (("QualifiedIdInClass", [ v1; v2 ])) + | TemplateDeclInClass v1 -> + let v1 = + (match v1 with + | (v1, v2, v3) -> + let v1 = vof_tok v1 + and v2 = vof_template_parameters v2 + and v3 = vof_declaration v3 + in Ocaml.VTuple [ v1; v2; v3 ]) + in Ocaml.VSum (("TemplateDeclInClass", [ v1 ])) + | UsingDeclInClass v1 -> + let v1 = + (match v1 with + | (v1, v2, v3) -> + let v1 = vof_tok v1 + and v2 = vof_name v2 + and v3 = vof_tok v3 + in Ocaml.VTuple [ v1; v2; v3 ]) + in Ocaml.VSum (("UsingDeclInClass", [ v1 ])) + | EmptyField v1 -> + let v1 = vof_tok v1 in Ocaml.VSum (("EmptyField", [ v1 ])) +and vof_fieldkind = + function + | FieldDecl v1 -> + let v1 = vof_onedecl v1 in Ocaml.VSum (("FieldDecl", [ v1 ])) + | BitField ((v1, v2, v3, v4)) -> + let v1 = Ocaml.vof_option (vof_wrap2 Ocaml.vof_string) v1 + and v2 = vof_tok v2 + and v3 = vof_fullType v3 + and v4 = vof_constExpression v4 + in Ocaml.VSum (("BitField", [ v1; v2; v3; v4 ])) +and vof_class_member_sequencable = + function + | ClassElem v1 -> + let v1 = vof_class_member v1 in Ocaml.VSum (("ClassElem", [ v1 ])) + | CppDirectiveStruct v1 -> + let v1 = vof_cpp_directive v1 + in Ocaml.VSum (("CppDirectiveStruct", [ v1 ])) + | IfdefStruct v1 -> + let v1 = vof_ifdef_directive v1 in Ocaml.VSum (("IfdefStruct", [ v1 ])) +and vof_cpp_directive = + function + | Define ((v1, v2, v3, v4)) -> + let v1 = vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + and v3 = vof_define_kind v3 + and v4 = vof_define_val v4 + in Ocaml.VSum (("Define", [ v1; v2; v3; v4 ])) + | Include ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_inc_kind v2 + and v3 = Ocaml.vof_string v3 + in Ocaml.VSum (("Include", [ v1; v2; v3 ])) + | Undef v1 -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + in Ocaml.VSum (("Undef", [ v1 ])) + | PragmaAndCo v1 -> + let v1 = vof_tok v1 in Ocaml.VSum (("PragmaAndCo", [ v1 ])) +and vof_define_kind = + function + | DefineVar -> Ocaml.VSum (("DefineVar", [])) + | DefineFunc v1 -> + let v1 = vof_paren (vof_comma_list (vof_wrap Ocaml.vof_string)) v1 + in Ocaml.VSum (("DefineFunc", [ v1 ])) +and vof_define_val = + function + | DefinePrintWrapper ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_paren vof_expression v2 + and v3 = vof_name v3 + in Ocaml.VSum (("DefinePrintWrapper", [ v1; v2; v3 ])) + | DefineExpr v1 -> + let v1 = vof_expression v1 in Ocaml.VSum (("DefineExpr", [ v1 ])) + | DefineStmt v1 -> + let v1 = vof_statement v1 in Ocaml.VSum (("DefineStmt", [ v1 ])) + | DefineType v1 -> + let v1 = vof_fullType v1 in Ocaml.VSum (("DefineType", [ v1 ])) + | DefineDoWhileZero v1 -> + let v1 = vof_wrap vof_statement v1 + in Ocaml.VSum (("DefineDoWhileZero", [ v1 ])) + | DefineFunction v1 -> + let v1 = vof_func_definition v1 + in Ocaml.VSum (("DefineFunction", [ v1 ])) + | DefineInit v1 -> + let v1 = vof_initialiser v1 in Ocaml.VSum (("DefineInit", [ v1 ])) + | DefineText v1 -> + let v1 = vof_wrap Ocaml.vof_string v1 + in Ocaml.VSum (("DefineText", [ v1 ])) + | DefineEmpty -> Ocaml.VSum (("DefineEmpty", [])) + | DefineTodo -> Ocaml.VSum (("DefineTodo", [])) +and vof_inc_kind = + function + | Local -> Ocaml.VSum (("Local", [ ])) + | Standard -> Ocaml.VSum (("Standard", [ ])) + | Weird -> Ocaml.VSum (("Weird", [ ])) + +and vof_ifdef_directive v = vof_wrap2 vof_ifdefkind v +and vof_ifdefkind = + function + | Ifdef -> Ocaml.VSum (("Ifdef", [])) + | IfdefElse -> Ocaml.VSum (("IfdefElse", [])) + | IfdefElseif -> Ocaml.VSum (("IfdefElseif", [])) + | IfdefEndif -> Ocaml.VSum (("IfdefEndif", [])) + +and vof_declaration = + function + | BlockDecl v1 -> + let v1 = vof_block_declaration v1 in Ocaml.VSum (("BlockDecl", [ v1 ])) + | Func v1 -> let v1 = vof_func_or_else v1 in Ocaml.VSum (("Func", [ v1 ])) + | TemplateDecl (v1, v2, v3) -> + let v1 = vof_tok v1 + and v2 = vof_template_parameters v2 + and v3 = vof_declaration v3 + in Ocaml.VSum (("TemplateDecl", [ v1; v2; v3 ])) + | TemplateSpecialization ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_angle Ocaml.vof_unit v2 + and v3 = vof_declaration v3 + in Ocaml.VSum (("TemplateSpecialization", [ v1; v2; v3 ])) + | ExternC ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_tok v2 + and v3 = vof_declaration v3 + in Ocaml.VSum (("ExternC", [ v1; v2; v3 ])) + | ExternCList ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_tok v2 + and v3 = vof_brace (Ocaml.vof_list vof_declaration_sequencable) v3 + in Ocaml.VSum (("ExternCList", [ v1; v2; v3 ])) + | NameSpace ((v1, v2, v3)) -> + let v1 = vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + and v3 = vof_brace (Ocaml.vof_list vof_declaration_sequencable) v3 + in Ocaml.VSum (("NameSpace", [ v1; v2; v3 ])) + | NameSpaceExtend ((v1, v2)) -> + let v1 = Ocaml.vof_string v1 + and v2 = Ocaml.vof_list vof_declaration_sequencable v2 + in Ocaml.VSum (("NameSpaceExtend", [ v1; v2 ])) + | NameSpaceAnon ((v1, v2)) -> + let v1 = vof_tok v1 + and v2 = vof_brace (Ocaml.vof_list vof_declaration_sequencable) v2 + in Ocaml.VSum (("NameSpaceAnon", [ v1; v2 ])) + | EmptyDef v1 -> let v1 = vof_tok v1 in Ocaml.VSum (("EmptyDef", [ v1 ])) + | DeclTodo -> Ocaml.VSum (("DeclTodo", [])) +and vof_template_parameter v = vof_parameter v +and vof_template_parameters v = + vof_angle (vof_comma_list vof_template_parameter) v +and vof_declaration_sequencable = + function + | NotParsedCorrectly v1 -> + let v1 = Ocaml.vof_list vof_tok v1 + in Ocaml.VSum (("NotParsedCorrectly", [ v1 ])) + | DeclElem v1 -> + let v1 = vof_declaration v1 in Ocaml.VSum (("DeclElem", [ v1 ])) + | CppDirectiveDecl v1 -> + let v1 = vof_cpp_directive v1 + in Ocaml.VSum (("CppDirectiveDecl", [ v1 ])) + | IfdefDecl v1 -> + let v1 = vof_ifdef_directive v1 in Ocaml.VSum (("IfdefDecl", [ v1 ])) + | MacroTop ((v1, v2, v3)) -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + and v2 = vof_paren (vof_comma_list vof_argument) v2 + and v3 = Ocaml.vof_option vof_tok v3 + in Ocaml.VSum (("MacroTop", [ v1; v2; v3 ])) + | MacroVarTop ((v1, v2)) -> + let v1 = vof_wrap2 Ocaml.vof_string v1 + and v2 = vof_tok v2 + in Ocaml.VSum (("MacroVarTop", [ v1; v2 ])) + +and vof_toplevel v = vof_declaration_sequencable v +and vof_program v = Ocaml.vof_list vof_toplevel v +and vof_any = + function + | Program v1 -> let v1 = vof_program v1 in Ocaml.VSum (("Program", [ v1 ])) + | Toplevel v1 -> + let v1 = vof_toplevel v1 in Ocaml.VSum (("Toplevel", [ v1 ])) + | BlockDecl2 v1 -> + let v1 = vof_block_declaration v1 + in Ocaml.VSum (("BlockDecl2", [ v1 ])) + | Stmt v1 -> let v1 = vof_statement v1 in Ocaml.VSum (("Stmt", [ v1 ])) + | Expr v1 -> let v1 = vof_expression v1 in Ocaml.VSum (("Expr", [ v1 ])) + | Init v1 -> let v1 = vof_initialiser v1 in Ocaml.VSum (("Init", [ v1 ])) + | Type v1 -> let v1 = vof_fullType v1 in Ocaml.VSum (("Type", [ v1 ])) + | Name v1 -> let v1 = vof_name v1 in Ocaml.VSum (("Name", [ v1 ])) + | Cpp v1 -> let v1 = vof_cpp_directive v1 in Ocaml.VSum (("Cpp", [ v1 ])) + | ClassDef v1 -> + let v1 = vof_class_definition v1 in Ocaml.VSum (("ClassDef", [ v1 ])) + | FuncDef v1 -> + let v1 = vof_func_definition v1 in Ocaml.VSum (("FuncDef", [ v1 ])) + | FuncOrElse v1 -> + let v1 = vof_func_or_else v1 in Ocaml.VSum (("FuncOrElse", [ v1 ])) + | Constant v1 -> + let v1 = vof_constant v1 in Ocaml.VSum (("Constant", [ v1 ])) + | Argument v1 -> + let v1 = vof_argument v1 in Ocaml.VSum (("Argument", [ v1 ])) + | Parameter v1 -> + let v1 = vof_parameter v1 in Ocaml.VSum (("Parameter", [ v1 ])) + | Body v1 -> let v1 = vof_compound v1 in Ocaml.VSum (("Body", [ v1 ])) + | Info v1 -> let v1 = vof_info v1 in Ocaml.VSum (("Info", [ v1 ])) + | InfoList v1 -> + let v1 = Ocaml.vof_list vof_info v1 + in Ocaml.VSum (("InfoList", [ v1 ])) + | ClassMember v1 -> + let v1 = vof_class_member v1 in + Ocaml.VSum (("ClassMember", [v1])) + | OneDecl v1 -> + let v1 = vof_onedecl v1 in + Ocaml.VSum (("OneDecl", [v1])) + + +(* end auto generation *) + +let vof_program ?(precision=M.default_precision) x = + Common.save_excursion _current_precision precision (fun () -> + vof_program x + ) + +let vof_any ?(precision=M.default_precision) x = + Common.save_excursion _current_precision precision (fun () -> + vof_any x + ) + diff --git a/lang_cpp/parsing/meta_ast_cpp.mli b/lang_cpp/parsing/meta_ast_cpp.mli new file mode 100644 index 0000000..71133c0 --- /dev/null +++ b/lang_cpp/parsing/meta_ast_cpp.mli @@ -0,0 +1,8 @@ + +val vof_program: + ?precision:Meta_ast_generic.precision -> + Ast_cpp.program -> Ocaml.v + +val vof_any: + ?precision:Meta_ast_generic.precision -> + Ast_cpp.any -> Ocaml.v diff --git a/lang_cpp/parsing/notes.txt b/lang_cpp/parsing/notes.txt new file mode 100644 index 0000000..c1db053 --- /dev/null +++ b/lang_cpp/parsing/notes.txt @@ -0,0 +1,38 @@ + + +cf engler article about all the difficulty they had because +had to find how to compile code!! + +same with elsa, need to know cpp flags. + +Well if do certain tools like refactorer, then partial code, +and have not all library code, and lots of other stuff +that cries for a different kind of approach: parse as is. + +sgrep_cpp also requires to parse patterns of code passed on the +command line. + + + +related work: + - FrontC of hughes casse + - CIL + + - EDG + - semantic designs + - elsa + - cppcheck + - llvm clang + - gcc xml + + +\section{When pb} + +pfff -parse_cpp xxx.cpp + +Maybe because of typedef inference is wrong. Had to extend heuristics. + +Maybe because template. Had to extend heuristics. + +Maybe because of macros. Had to extend macros.h + diff --git a/lang_cpp/parsing/orig_c.mly b/lang_cpp/parsing/orig_c.mly new file mode 100644 index 0000000..d4c682a --- /dev/null +++ b/lang_cpp/parsing/orig_c.mly @@ -0,0 +1,320 @@ +%{ +(* src: ocamlyaccified from + * http://www.lysator.liu.se/c/ANSI-C-grammar-y.html + *) +open Common +open AbstractSyntax +exception Parsing of string +%} + +%token TString +%token TIdent +%token TInt +%token TFloat + +/*(* conflicts *)*/ +%token TypedefIdent + +%token TOPar TCPar TOBrace TCBrace TOCro TCCro +%token TDot TComma TPtrOp +%token TInc TDec +%token TAssign +%token TEq +%token TWhy TDotDot TPtVirg TTilde TBang +%token TEllipsis + +%token TOrLog TAndLog TOrIncl TOrExcl TAnd TEqEq TNotEq TInf TSup TInfEq TSupEq TShl TShr + TPlus TMinus TMul TDiv TMod + +%token Tchar Tshort Tint Tdouble Tfloat Tlong Tunsigned Tsigned Tvoid + Tauto Tregister Textern Tstatic + Tconst Tvolatile + Tstruct Tenum Ttypedef Tunion + Tbreak Telse Tswitch Tcase Tcontinue Tfor Tdo Tif Twhile Treturn Tgoto Tdefault + Tsizeof + +%token EOF + + +%left TOrLog +%left TAndLog +%left TOrIncl +%left TOrExcl +%left TAnd +%left TEqEq TNotEq +%left TInf TSup TInfEq TSupEq +%left TShl TShr +%left TPlus TMinus +%left TMul TDiv TMod + +%start main +%type main +%% + +main: translation_unit EOF { [] } + +/********************************************************************************/ +/* + expression + statement + declaration + main +*/ + +/********************************************************************************/ + +expr: assign_expr { } + | expr TComma assign_expr { } + +assign_expr: cond_expr { } + | unary_expr TAssign assign_expr { } + | unary_expr TEq assign_expr { } + +cond_expr: arith_expr {} + | arith_expr TWhy expr TDotDot cond_expr {} + +arith_expr: cast_expr {} + | arith_expr TMul arith_expr {} + | arith_expr TDiv arith_expr {} + | arith_expr TMod arith_expr {} + | arith_expr TPlus arith_expr {} + | arith_expr TMinus arith_expr {} + | arith_expr TShl arith_expr {} + | arith_expr TShr arith_expr {} + | arith_expr TInf arith_expr {} + | arith_expr TSup arith_expr {} + | arith_expr TInfEq arith_expr {} + | arith_expr TSupEq arith_expr {} + | arith_expr TEqEq arith_expr {} + | arith_expr TNotEq arith_expr {} + | arith_expr TAnd arith_expr {} + | arith_expr TOrExcl arith_expr {} + | arith_expr TOrIncl arith_expr {} + | arith_expr TAndLog arith_expr {} + | arith_expr TOrLog arith_expr {} + +cast_expr: unary_expr {} + | TOPar type_name TCPar cast_expr {} + +unary_expr: postfix_expr {} + | TInc unary_expr {} + | TDec unary_expr {} + | unary_op cast_expr {} + | Tsizeof unary_expr {} + | Tsizeof TOPar type_name TCPar {} + +unary_op: TAnd {} + | TMul {} + | TPlus {} + | TMinus{} + | TTilde{} + | TBang {} + +postfix_expr: primary_expr {} + | postfix_expr TOCro expr TCCro {} + | postfix_expr TOPar argument_expr_list TCPar {} + | postfix_expr TOPar TCPar {} + | postfix_expr TDot TIdent {} + | postfix_expr TPtrOp TIdent {} + | postfix_expr TInc {} + | postfix_expr TDec {} + +argument_expr_list: assign_expr { } + | argument_expr_list TComma assign_expr {} + +primary_expr: TIdent {} + | TInt {} + | TFloat {} + | TString {} + | TOPar expr TCPar {} + +const_expr: cond_expr {} +/********************************************************************************/ + +statement: labeled {} + | compound {} + | expr_statement {} + | selection {} + | iteration {} + | jump TPtVirg {} + +labeled: TIdent TDotDot statement {} + | Tcase const_expr TDotDot statement {} + | Tdefault TDotDot statement {} + +compound: TOBrace TCBrace {} + | TOBrace statement_list TCBrace {} + | TOBrace decl_list TCBrace {} + | TOBrace decl_list statement_list TCBrace {} + +decl_list: decl {} + | decl decl_list {} + +statement_list: statement {} + | statement statement_list {} + +expr_statement: TPtVirg {} + | expr TPtVirg {} + +selection: Tif TOPar expr TCPar statement {} + | Tif TOPar expr TCPar statement Telse statement {} + | Tswitch TOPar expr TCPar statement {} + +iteration: Twhile TOPar expr TCPar statement {} + | Tdo statement Twhile TOPar expr TCPar TPtVirg {} + | Tfor TOPar expr_statement expr_statement TCPar statement {} + | Tfor TOPar expr_statement expr_statement expr TCPar statement {} + +jump: Tgoto TIdent {} + | Tcontinue {} + | Tbreak {} + | Treturn {} + | Treturn expr {} + +/********************************************************************************/ + +/*------------------------------------------------------------------------------*/ +decl: decl_spec TPtVirg {} + | decl_spec init_declarator_list TPtVirg {} + +/*------------------------------------------------------------------------------*/ +decl_spec: storage_class_spec {} + | storage_class_spec decl_spec {} + | type_spec {} + | type_spec decl_spec {} + | type_qualif {} + | type_qualif decl_spec {} + +storage_class_spec: Tstatic {} + | Textern {} + | Tauto {} + | Tregister {} + | Ttypedef {} +type_spec: Tvoid {} + | Tchar {} + | Tshort {} + | Tint {} + | Tlong {} + | Tfloat {} + | Tdouble {} + | Tsigned {} + | Tunsigned {} + | struct_or_union_spec {} + | enum_spec {} +/*TODO | TIdent {} */ + | TypedefIdent {} + +type_qualif: Tconst {} + | Tvolatile {} + +/*------------------------------------------------------------------------------*/ +struct_or_union_spec: struct_or_union TIdent TOBrace struct_decl_list TCBrace {} + | struct_or_union TOBrace struct_decl_list TCBrace {} + | struct_or_union TIdent {} + +struct_or_union: Tstruct {} + | Tunion {} + +struct_decl_list: struct_decl {} + | struct_decl_list struct_decl {} + +struct_decl: spec_qualif_list struct_declarator_list TPtVirg {} + +spec_qualif_list: type_spec {} + | type_spec spec_qualif_list {} + | type_qualif {} + | type_qualif spec_qualif_list {} + +struct_declarator_list: struct_declarator {} + | struct_declarator_list TComma struct_declarator {} +struct_declarator: declarator {} + | TDotDot const_expr {} + | declarator TDotDot const_expr {} +/*------------------------------------------------------------------------------*/ +enum_spec: Tenum TOBrace enumerator_list TCBrace {} + | Tenum TIdent TOBrace enumerator_list TCBrace {} + | Tenum TIdent {} + +enumerator_list: enumerator {} + | enumerator_list TComma enumerator {} + +enumerator: TIdent {} + | TIdent TEq const_expr {} +/*------------------------------------------------------------------------------*/ + +init_declarator_list: init_declarator {} + | init_declarator_list TComma init_declarator {} + +init_declarator: declarator {} + | declarator TEq initialize {} + +/*------------------------------------------------------------------------------*/ +declarator: pointer direct_declarator {} + | direct_declarator {} + +pointer: TMul {} + | TMul type_qualif_list {} + | TMul pointer {} + | TMul type_qualif_list pointer {} + +direct_declarator: TIdent {} + | TOPar declarator TCPar {} + | direct_declarator TOCro const_expr TCCro {} + | direct_declarator TOCro TCCro {} + | direct_declarator TOPar TCPar {} + | direct_declarator TOPar parameter_type_list TCPar {} + | direct_declarator TOPar identifier_list TCPar {} + +type_qualif_list: type_qualif {} + | type_qualif_list type_qualif {} + +parameter_type_list: parameter_list {} + | parameter_list TComma TEllipsis {} + +parameter_list: parameter_decl {} + | parameter_list TComma parameter_decl {} + +parameter_decl: decl_spec declarator {} + | decl_spec abstract_declarator {} + | decl_spec {} +identifier_list: TIdent {} + | identifier_list TComma TIdent {} +/*------------------------------------------------------------------------------*/ + +type_name: spec_qualif_list {} + | spec_qualif_list abstract_declarator {} + +abstract_declarator: pointer {} + | direct_abstract_declarator {} + | pointer direct_abstract_declarator {} + +direct_abstract_declarator: TOPar abstract_declarator TCPar {} + | TOCro TCCro {} + | TOCro const_expr TCCro {} + | direct_abstract_declarator TOCro TCCro {} + | direct_abstract_declarator TOCro const_expr TCCro {} + | TOPar TCPar {} + | TOPar parameter_type_list TCPar {} + | direct_abstract_declarator TOPar TCPar {} + | direct_abstract_declarator TOPar parameter_type_list TCPar {} + +/*------------------------------------------------------------------------------*/ +initialize: assign_expr {} + | TOBrace initialize_list TCBrace {} + | TOBrace initialize_list TComma TCBrace {} + +initialize_list: initialize {} + | initialize_list TComma initialize {} + +/********************************************************************************/ + +translation_unit: external_declaration {} + | translation_unit external_declaration {} + +external_declaration: function_definition {} + | decl {} + +function_definition: decl_spec declarator decl_list compound {} + | decl_spec declarator compound {} + | declarator decl_list compound {} + | declarator compound {} diff --git a/lang_cpp/parsing/orig_cpp.mly b/lang_cpp/parsing/orig_cpp.mly new file mode 100644 index 0000000..6989bd4 --- /dev/null +++ b/lang_cpp/parsing/orig_cpp.mly @@ -0,0 +1,759 @@ +src: http://www.csci.csusb.edu/dick/c++std/cd2/gram.html + +pad: -seq, -opt suffix + +1 This summary of C++ syntax is intended to be an aid to comprehension. + It is not an exact statement of the language. In particular, the + grammar described here accepts a superset of valid C++ constructs. + Disambiguation rules (_stmt.ambig_, _dcl.spec_, _class.member.lookup_) + must be applied to distinguish expressions from declarations. Fur- + ther, access control, ambiguity, and type rules must be used to weed + out syntactically valid but meaningless constructs. + + 1.1 Keywords [gram.key] + +1 New context-dependent keywords are introduced into a program by type- + def (_dcl.typedef_), namespace (_namespace.def_), class (_class_), + enumeration (_dcl.enum_), and template (_temp_) declarations. + typedef-name: + identifier + namespace-name: + original-namespace-name + namespace-alias + + original-namespace-name: + identifier + + namespace-alias: + identifier + class-name: + identifier + template-id + enum-name: + identifier + template-name: + identifier + Note that a typedef-name naming a class is also a class-name + (_class.name_). + + 1.2 Lexical conventions [gram.lex] + hex-quad: + hexadecimal-digit hexadecimal-digit hexadecimal-digit hexadecimal-digit + + universal-character-name: + \u hex-quad + \U hex-quad hex-quad + + preprocessing-token: + header-name + identifier + pp-number + character-literal + string-literal + preprocessing-op-or-punc + each non-white-space character that cannot be one of the above + token: + identifier + keyword + literal + operator + punctuator + header-name: + + "q-char-sequence" + h-char-sequence: + h-char + h-char-sequence h-char + h-char: + any member of the source character set except + new-line and > + q-char-sequence: + q-char + q-char-sequence q-char + q-char: + any member of the source character set except + new-line and " " + pp-number: + digit + . digit + pp-number digit + pp-number nondigit + pp-number e sign + pp-number E sign + pp-number . + identifier: + nondigit + identifier nondigit + identifier digit + nondigit: one of + universal-character-name + _ a b c d e f g h i j k l m + n o p q r s t u v w x y z + A B C D E F G H I J K L M + N O P Q R S T U V W X Y Z + digit: one of + 0 1 2 3 4 5 6 7 8 9 + + preprocessing-op-or-punc: one of + { } [ ] # ## ( ) + <: :> <% %> %: %:%: ; : ... + new delete ? :: . .* + + - * / % ^ & | ~ + ! = < > += -= *= /= %= + ^= &= |= << >> >>= <<= == != + <= >= && || ++ -- , ->* -> + and and_eq bitand bitor compl not not_eq or or_eq + xor xor_eq + + literal: + integer-literal + character-literal + floating-literal + string-literal + boolean-literal + integer-literal: + decimal-literal integer-suffixopt + octal-literal integer-suffixopt + hexadecimal-literal integer-suffixopt + decimal-literal: + nonzero-digit + decimal-literal digit + octal-literal: + 0 + octal-literal octal-digit + hexadecimal-literal: + 0x hexadecimal-digit + 0X hexadecimal-digit + hexadecimal-literal hexadecimal-digit + nonzero-digit: one of + 1 2 3 4 5 6 7 8 9 + octal-digit: one of + 0 1 2 3 4 5 6 7 + hexadecimal-digit: one of + 0 1 2 3 4 5 6 7 8 9 + a b c d e f + A B C D E F + integer-suffix: + unsigned-suffix long-suffixopt + long-suffix unsigned-suffixopt + unsigned-suffix: one of + u U + long-suffix: one of + l L + character-literal: + 'c-char-sequence' + L'c-char-sequence' + c-char-sequence: + c-char + c-char-sequence c-char + + c-char: + any member of the source character set except + the single-quote ', backslash \, or new-line character + escape-sequence + universal-character-name + escape-sequence: + simple-escape-sequence + octal-escape-sequence + hexadecimal-escape-sequence + simple-escape-sequence: one of + \' \" \? \\ " + \a \b \f \n \r \t \v + octal-escape-sequence: + \ octal-digit + \ octal-digit octal-digit + \ octal-digit octal-digit octal-digit + hexadecimal-escape-sequence: + \x hexadecimal-digit + hexadecimal-escape-sequence hexadecimal-digit + floating-literal: + fractional-constant exponent-partopt floating-suffixopt + digit-sequence exponent-part floating-suffixopt + fractional-constant: + digit-sequenceopt . digit-sequence + digit-sequence . + exponent-part: + e signopt digit-sequence + E signopt digit-sequence + sign: one of + + - + digit-sequence: + digit + digit-sequence digit + floating-suffix: one of + f l F L + string-literal: + "s-char-sequenceopt" + L"s-char-sequenceopt" + s-char-sequence: + s-char + s-char-sequence s-char + s-char: + any member of the source character set except + the double-quote ", backslash \, or new-line character " + escape-sequence + universal-character-name + boolean-literal: + false + true + + 1.3 Basic concepts [gram.basic] + translation-unit: + declaration-seqopt + + 1.4 Expressions [gram.expr] + primary-expression: + literal + this + :: identifier + :: operator-function-id + :: qualified-id + ( expression ) + id-expression + + id-expression: + unqualified-id + qualified-id + + unqualified-id: + identifier + operator-function-id + conversion-function-id + ~ class-name + template-id + qualified-id: + nested-name-specifier templateopt unqualified-id + nested-name-specifier: + class-or-namespace-name :: nested-name-specifieropt + + class-or-namespace-name: + class-name + namespace-name + postfix-expression: + primary-expression + postfix-expression [ expression ] + postfix-expression ( expression-listopt ) + simple-type-specifier ( expression-listopt ) + postfix-expression . templateopt ::opt id-expression + postfix-expression -> templateopt ::opt id-expression + postfix-expression . pseudo-destructor-name + postfix-expression -> pseudo-destructor-name + postfix-expression ++ + postfix-expression -- + dynamic_cast < type-id > ( expression ) + static_cast < type-id > ( expression ) + reinterpret_cast < type-id > ( expression ) + const_cast < type-id > ( expression ) + typeid ( expression ) + typeid ( type-id ) + + expression-list: + assignment-expression + expression-list , assignment-expression + pseudo-destructor-name: + ::opt nested-name-specifieropt type-name :: ~ type-name + ::opt nested-name-specifieropt ~ type-name + unary-expression: + postfix-expression + ++ cast-expression + -- cast-expression + unary-operator cast-expression + sizeof unary-expression + sizeof ( type-id ) + new-expression + delete-expression + unary-operator: one of + * & + - ! ~ + new-expression: + ::opt new new-placementopt new-type-id new-initializeropt + ::opt new new-placementopt ( type-id ) new-initializeropt + new-placement: + ( expression-list ) + new-type-id: + type-specifier-seq new-declaratoropt + new-declarator: + ptr-operator new-declaratoropt + direct-new-declarator + direct-new-declarator: + [ expression ] + direct-new-declarator [ constant-expression ] + new-initializer: + ( expression-listopt ) + delete-expression: + ::opt delete cast-expression + ::opt delete [ ] cast-expression + cast-expression: + unary-expression + ( type-id ) cast-expression + pm-expression: + cast-expression + pm-expression .* cast-expression + pm-expression ->* cast-expression + multiplicative-expression: + pm-expression + multiplicative-expression * pm-expression + multiplicative-expression / pm-expression + multiplicative-expression % pm-expression + additive-expression: + multiplicative-expression + additive-expression + multiplicative-expression + additive-expression - multiplicative-expression + + shift-expression: + additive-expression + shift-expression << additive-expression + shift-expression >> additive-expression + relational-expression: + shift-expression + relational-expression < shift-expression + relational-expression > shift-expression + relational-expression <= shift-expression + relational-expression >= shift-expression + equality-expression: + relational-expression + equality-expression == relational-expression + equality-expression != relational-expression + and-expression: + equality-expression + and-expression & equality-expression + exclusive-or-expression: + and-expression + exclusive-or-expression ^ and-expression + inclusive-or-expression: + exclusive-or-expression + inclusive-or-expression | exclusive-or-expression + logical-and-expression: + inclusive-or-expression + logical-and-expression && inclusive-or-expression + logical-or-expression: + logical-and-expression + logical-or-expression || logical-and-expression + conditional-expression: + logical-or-expression + logical-or-expression ? expression : assignment-expression + assignment-expression: + conditional-expression + logical-or-expression assignment-operator assignment-expression + throw-expression + assignment-operator: one of + = *= /= %= += -= >>= <<= &= ^= |= + expression: + assignment-expression + expression , assignment-expression + constant-expression: + conditional-expression + + 1.5 Statements [gram.stmt.stmt] + statement: + labeled-statement + expression-statement + compound-statement + selection-statement + iteration-statement + jump-statement + declaration-statement + try-block + + labeled-statement: + identifier : statement + case constant-expression : statement + default : statement + expression-statement: + expressionopt ; + compound-statement: + { statement-seqopt } + statement-seq: + statement + statement-seq statement + selection-statement: + if ( condition ) statement + if ( condition ) statement else statement + switch ( condition ) statement + condition: + expression + type-specifier-seq declarator = assignment-expression + iteration-statement: + while ( condition ) statement + do statement while ( expression ) ; + for ( for-init-statement conditionopt ; expressionopt ) statement + for-init-statement: + expression-statement + simple-declaration + jump-statement: + break ; + continue ; + return expressionopt ; + goto identifier ; + declaration-statement: + block-declaration + + 1.6 Declarations [gram.dcl.dcl] + declaration-seq: + declaration + declaration-seq declaration + declaration: + block-declaration + function-definition + template-declaration + explicit-instantiation + explicit-specialization + linkage-specification + namespace-definition + block-declaration: + simple-declaration + asm-definition + namespace-alias-definition + using-declaration + using-directive + simple-declaration: + decl-specifier-seqopt init-declarator-listopt ; + + decl-specifier: + storage-class-specifier + type-specifier + function-specifier + friend + typedef + decl-specifier-seq: + decl-specifier-seqopt decl-specifier + storage-class-specifier: + auto + register + static + extern + mutable + function-specifier: + inline + virtual + explicit + typedef-name: + identifier + type-specifier: + simple-type-specifier + class-specifier + enum-specifier + elaborated-type-specifier + cv-qualifier + simple-type-specifier: + ::opt nested-name-specifieropt type-name + char + wchar_t + bool + short + int + long + signed + unsigned + float + double + void + type-name: + class-name + enum-name + typedef-name + elaborated-type-specifier: + class-key ::opt nested-name-specifieropt identifier + enum ::opt nested-name-specifieropt identifier + typename ::opt nested-name-specifier identifier + typename ::opt nested-name-specifier identifier < template-argument-list > + enum-name: + identifier + enum-specifier: + enum identifieropt { enumerator-listopt } + + enumerator-list: + enumerator-definition + enumerator-list , enumerator-definition + enumerator-definition: + enumerator + enumerator = constant-expression + enumerator: + identifier + namespace-name: + original-namespace-name + namespace-alias + original-namespace-name: + identifier + + namespace-definition: + named-namespace-definition + unnamed-namespace-definition + + named-namespace-definition: + original-namespace-definition + extension-namespace-definition + + original-namespace-definition: + namespace identifier { namespace-body } + + extension-namespace-definition: + namespace original-namespace-name { namespace-body } + + unnamed-namespace-definition: + namespace { namespace-body } + + namespace-body: + declaration-seqopt + namespace-alias: + identifier + + namespace-alias-definition: + namespace identifier = qualified-namespace-specifier ; + + qualified-namespace-specifier: + ::opt nested-name-specifieropt namespace-name + using-declaration: + using typenameopt ::opt nested-name-specifier unqualified-id ; + using :: unqualified-id ; + using-directive: + using namespace ::opt nested-name-specifieropt namespace-name ; + asm-definition: + asm ( string-literal ) ; + linkage-specification: + extern string-literal { declaration-seqopt } + extern string-literal declaration + + 1.7 Declarators [gram.dcl.decl] + init-declarator-list: + init-declarator + init-declarator-list , init-declarator + init-declarator: + declarator initializeropt + declarator: + direct-declarator + ptr-operator declarator + direct-declarator: + declarator-id + direct-declarator ( parameter-declaration-clause ) cv-qualifier-seqopt exception-specificationopt + direct-declarator [ constant-expressionopt ] + ( declarator ) + ptr-operator: + * cv-qualifier-seqopt + & + ::opt nested-name-specifier * cv-qualifier-seqopt + cv-qualifier-seq: + cv-qualifier cv-qualifier-seqopt + cv-qualifier: + const + volatile + declarator-id: + ::opt id-expression + ::opt nested-name-specifieropt type-name + type-id: + type-specifier-seq abstract-declaratoropt + type-specifier-seq: + type-specifier type-specifier-seqopt + abstract-declarator: + ptr-operator abstract-declaratoropt + direct-abstract-declarator + direct-abstract-declarator: + direct-abstract-declaratoropt ( parameter-declaration-clause ) cv-qualifier-seqopt exception-specificationopt + direct-abstract-declaratoropt [ constant-expressionopt ] + ( abstract-declarator ) + parameter-declaration-clause: + parameter-declaration-listopt ...opt + parameter-declaration-list , ... + parameter-declaration-list: + parameter-declaration + parameter-declaration-list , parameter-declaration + parameter-declaration: + decl-specifier-seq declarator + decl-specifier-seq declarator = assignment-expression + decl-specifier-seq abstract-declaratoropt + decl-specifier-seq abstract-declaratoropt = assignment-expression + function-definition: + decl-specifier-seqopt declarator ctor-initializeropt function-body + decl-specifier-seqopt declarator function-try-block + + function-body: + compound-statement + + initializer: + = initializer-clause + ( expression-list ) + initializer-clause: + assignment-expression + { initializer-list ,opt } + { } + initializer-list: + initializer-clause + initializer-list , initializer-clause + + 1.8 Classes [gram.class] + class-name: + identifier + template-id + class-specifier: + class-head { member-specificationopt } + class-head: + class-key identifieropt base-clauseopt + class-key nested-name-specifier identifier base-clauseopt + class-key: + class + struct + union + member-specification: + member-declaration member-specificationopt + access-specifier : member-specificationopt + member-declaration: + decl-specifier-seqopt member-declarator-listopt ; + function-definition ;opt + qualified-id ; + using-declaration + template-declaration + member-declarator-list: + member-declarator + member-declarator-list , member-declarator + member-declarator: + declarator pure-specifieropt + declarator constant-initializeropt + identifieropt : constant-expression + pure-specifier: + = 0 + constant-initializer: + = constant-expression + + 1.9 Derived classes [gram.class.derived] + base-clause: + : base-specifier-list + base-specifier-list: + base-specifier + base-specifier-list , base-specifier + + base-specifier: + ::opt nested-name-specifieropt class-name + virtual access-specifieropt ::opt nested-name-specifieropt class-name + access-specifier virtualopt ::opt nested-name-specifieropt class-name + access-specifier: + private + protected + public + + 1.10 Special member functions [gram.special] + conversion-function-id: + operator conversion-type-id + conversion-type-id: + type-specifier-seq conversion-declaratoropt + conversion-declarator: + ptr-operator conversion-declaratoropt + ctor-initializer: + : mem-initializer-list + mem-initializer-list: + mem-initializer + mem-initializer , mem-initializer-list + mem-initializer: + mem-initializer-id ( expression-listopt ) + mem-initializer-id: + ::opt nested-name-specifieropt class-name + identifier + + 1.11 Overloading [gram.over] + operator-function-id: + operator operator + operator: one of + new delete new[] delete[] + + - * / % ^ & | ~ + ! = < > += -= *= /= %= + ^= &= |= << >> >>= <<= == != + <= >= && || ++ -- , ->* -> + () [] + + 1.12 Templates [gram.temp] + template-declaration: + exportopt template < template-parameter-list > declaration + template-parameter-list: + template-parameter + template-parameter-list , template-parameter + template-parameter: + type-parameter + parameter-declaration + type-parameter: + class identifieropt + class identifieropt = type-id + typename identifieropt + typename identifieropt = type-id + template < template-parameter-list > class identifieropt + template < template-parameter-list > class identifieropt = template-name + + template-id: + template-name < template-argument-list > + template-name: + identifier + template-argument-list: + template-argument + template-argument-list , template-argument + template-argument: + assignment-expression + type-id + template-name + explicit-instantiation: + template-declaration + explicit-specialization: + template < > declaration + + 1.13 Exception handling [gram.except] + try-block: + try compound-statement handler-seq + function-try-block: + try ctor-initializeropt function-body handler-seq + handler-seq: + handler handler-seqopt + handler: + catch ( exception-declaration ) compound-statement + exception-declaration: + type-specifier-seq declarator + type-specifier-seq abstract-declarator + type-specifier-seq + ... + throw-expression: + throw assignment-expressionopt + exception-specification: + throw ( type-id-listopt ) + type-id-list: + type-id + type-id-list , type-id + + 1.14 Preprocessing directives [gram.cpp] + preprocessing-file: + groupopt + group: + group-part + group group-part + group-part: + pp-tokensopt new-line + if-section + control-line + if-section: + if-group elif-groupsopt else-groupopt endif-line + if-group: + # if constant-expression new-line groupopt + # ifdef identifier new-line groupopt + # ifndef identifier new-line groupopt + + elif-groups: + elif-group + elif-groups elif-group + elif-group: + # elif constant-expression new-line groupopt + else-group: + # else new-line groupopt + endif-line: + # endif new-line + control-line: + # include pp-tokens new-line + # define identifier replacement-list new-line + # define identifier lparen identifier-listopt ) replacement-list new-line + # undef identifier new-line + # line pp-tokens new-line + # error pp-tokensopt new-line + # pragma pp-tokensopt new-line + # new-line + lparen: + the left-parenthesis character without preceding white-space + replacement-list: + pp-tokensopt + pp-tokens: + preprocessing-token + pp-tokens preprocessing-token + new-line: + the new-line character diff --git a/lang_cpp/parsing/parse_cpp.ml b/lang_cpp/parsing/parse_cpp.ml new file mode 100644 index 0000000..64c0967 --- /dev/null +++ b/lang_cpp/parsing/parse_cpp.ml @@ -0,0 +1,506 @@ +(* Yoann Padioleau + * + * Copyright (C) 2002-2013 Yoann Padioleau + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module Ast = Ast_cpp +module Flag = Flag_parsing_cpp +module PI = Parse_info +module Stat = Parse_info +module T = Parser_cpp +module TH = Token_helpers_cpp +module Lexer = Lexer_cpp +module Semantic = Parser_cpp_mly_helper +module Hack = Parsing_hacks_lib +module FT = File_type + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * A heuristic based C/cpp/C++ parser. + * + * See "Parsing C/C++ Code without Pre-Preprocessing - Yoann Padioleau, CC'09" + * avalaible at http://padator.org/papers/yacfe-cc09.pdf + *) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type toplevels_and_tokens = (Ast.toplevel * Parser_cpp.token list) list + +let program_of_program2 xs = + xs +> List.map fst + +exception Parse_error of Parse_info.info + +(*****************************************************************************) +(* Wrappers *) +(*****************************************************************************) +let pr2, _pr2_once = Common2.mk_pr2_wrappers Flag_parsing_cpp.verbose_parsing + +(*****************************************************************************) +(* Error diagnostic *) +(*****************************************************************************) + +let error_msg_tok tok = + Parse_info.error_message_info (TH.info_of_tok tok) + +(*****************************************************************************) +(* Stats on what was passed/commentized *) +(*****************************************************************************) + +let commentized xs = xs +> Common.map_filter (function + | T.TComment_Pp (cppkind, ii) -> + if !Flag.filter_classic_passed + then + (match cppkind with + | Token_cpp.CppOther -> + let s = PI.str_of_info ii in + (match s with + | s when s =~ "KERN_.*" -> None + | s when s =~ "__.*" -> None + | _ -> Some (ii.PI.token) + ) + + | Token_cpp.CppDirective | Token_cpp.CppAttr | Token_cpp.CppMacro + -> None + | Token_cpp.CppMacroExpanded + | Token_cpp.CppPassingNormal + | Token_cpp.CppPassingCosWouldGetError + -> raise Todo + ) + else Some (ii.PI.token) + + | T.TAny_Action ii -> + Some (ii.PI.token) + | _ -> + None + ) + +let count_lines_commentized xs = + let line = ref (-1) in + let count = ref 0 in + commentized xs +> List.iter (function + | PI.OriginTok pinfo + | PI.ExpandedTok (_,pinfo,_) -> + let newline = pinfo.PI.line in + if newline <> !line + then begin + line := newline; + incr count + end + | _ -> () + ); + !count + + +(* See also problematic_lines and parsing_stat.ml *) + +(* for most problematic tokens *) +let is_same_line_or_close line tok = + TH.line_of_tok tok =|= line || + TH.line_of_tok tok =|= line - 1 || + TH.line_of_tok tok =|= line - 2 + +(*****************************************************************************) +(* Lexing only *) +(*****************************************************************************) + +(* called by parse below *) +let tokens2 file = + let table = Parse_info.full_charpos_to_pos_large file in + + Common.with_open_infile file (fun chan -> + let lexbuf = Lexing.from_channel chan in + try + let rec tokens_aux () = + let tok = Lexer.token lexbuf in + (* fill in the line and col information *) + let tok = tok +> TH.visitor_info_of_tok (fun ii -> + { ii with PI.token= + (* could assert pinfo.filename = file ? *) + match ii.PI.token with + | PI.OriginTok pi -> + PI.OriginTok (Parse_info.complete_token_location_large file + table pi) + | PI.ExpandedTok (pi,vpi, off) -> + PI.ExpandedTok( + (Parse_info.complete_token_location_large file table pi),vpi, + off) + | PI.FakeTokStr (s,vpi_opt) -> PI.FakeTokStr (s,vpi_opt) + | PI.Ab -> raise Impossible + }) + in + + if TH.is_eof tok + then [tok] + else tok::(tokens_aux ()) + in + tokens_aux () + with + | Lexer.Lexical s -> + failwith (spf "lexical error %s \n = %s" + s (PI.error_message file (PI.lexbuf_to_strpos lexbuf))) + | e -> raise e + ) + +let tokens a = + Common.profile_code "Parse_cpp.tokens" (fun () -> tokens2 a) + +(*****************************************************************************) +(* Fuzzy parsing *) +(*****************************************************************************) + +let rec multi_grouped_list xs = + xs +> List.map multi_grouped + +and multi_grouped = function + | Token_views_cpp.Braces (tok1, xs, (Some tok2)) -> + Ast_fuzzy.Braces (tokext tok1, multi_grouped_list xs, tokext tok2) + | Token_views_cpp.Parens (tok1, xs, (Some tok2)) -> + Ast_fuzzy.Parens (tokext tok1, multi_grouped_list_comma xs, tokext tok2) + | Token_views_cpp.Angle (tok1, xs, (Some tok2)) -> + Ast_fuzzy.Angle (tokext tok1, multi_grouped_list xs, tokext tok2) + | Token_views_cpp.Tok (tok) -> + (match PI.str_of_info (tokext tok) with + | "..." -> Ast_fuzzy.Dots (tokext tok) + | s when Ast_fuzzy.is_metavar s -> Ast_fuzzy.Metavar (s, tokext tok) + | s -> Ast_fuzzy.Tok (s, tokext tok) + ) + | _ -> failwith "could not find closing brace/parens/angle" +and tokext tok_extended = + TH.info_of_tok tok_extended.Token_views_cpp.t +and multi_grouped_list_comma xs = + let rec aux acc xs = + match xs with + | [] -> + if null acc + then [] + else [Left (acc +> List.rev +> multi_grouped_list)] + | (x::xs) -> + (match x with + | Token_views_cpp.Tok tok when PI.str_of_info (tokext tok) = "," -> + let before = acc +> List.rev +> multi_grouped_list in + if null before + then aux [] xs + else (Left before)::(Right (tokext tok))::aux [] xs + | _ -> + aux (x::acc) xs + ) + in + aux [] xs + + +(* This is similar to what I did for OPA. This is also similar + * to what I do for parsing hacks, but this fuzzy AST can be useful + * on its own, e.g. for a not too bad sgrep/spatch. + * + * note: this is similar to what cpplint/fblint of andrei does? + *) +let parse_fuzzy file = + Common.save_excursion Flag.sgrep_mode true (fun () -> + let toks_orig = tokens file in + let toks = + toks_orig +> Common.exclude (fun x -> + Token_helpers_cpp.is_comment x || Token_helpers_cpp.is_eof x + ) + in + let extended = toks +> List.map Token_views_cpp.mk_token_extended in + Parsing_hacks_cpp.find_template_inf_sup extended; + let groups = Token_views_cpp.mk_multi extended in + multi_grouped_list groups, toks_orig + ) + +(*****************************************************************************) +(* Extract macros *) +(*****************************************************************************) + +(* It can be used to to parse the macros defined in a macro.h file. It + * can also be used to try to extract the macros defined in the file + * that we try to parse *) +let extract_macros2 file = + Common.save_excursion Flag_parsing_cpp.verbose_lexing false (fun () -> + let toks = tokens (* todo: ~profile:false *) file in + let toks = Parsing_hacks_define.fix_tokens_define toks in + Pp_token.extract_macros toks + ) +let extract_macros a = + Common.profile_code_exclusif "Parse_cpp.extract_macros" (fun () -> + extract_macros2 a) + +(* less: pass it as a parameter to parse_program instead ? + * old: was a ref, but a hashtbl.t is actually already a kind of ref + *) +let (_defs : (string, Pp_token.define_body) Hashtbl.t) = + Hashtbl.create 101 + + +(* We used to have also a init_defs_builtins() so that we could use a + * standard.h containing macros that were always useful, and a macros.h + * that the user could customize for his own project. + * But this was adding complexity so now we just have _defs and people + * can call add_defs to add local macro definitions. + *) +let add_defs file = + if not (Sys.file_exists file) + then failwith (spf "Could not find %s, have you set PFFF_HOME correctly?" + file); + pr2 (spf "Using %s macro file" file); + let xs = extract_macros file in + xs +> List.iter (fun (k, v) -> Hashtbl.add _defs k v) + +let init_defs file = + Hashtbl.clear _defs; + add_defs file + +(*****************************************************************************) +(* Error recovery *) +(*****************************************************************************) +(* see parsing_recovery_cpp.ml *) + +(*****************************************************************************) +(* Consistency checking *) +(*****************************************************************************) +(* todo: a parsing_consistency_cpp.ml *) + +(*****************************************************************************) +(* Helper for main entry point *) +(*****************************************************************************) + +(* Hacked lex. This function use refs passed by parse. + * 'tr' means 'token refs'. This is used mostly to enable + * error recovery (This used to do lots of stuff, such as + * calling some lookahead heuristics to reclassify + * tokens such as TIdent into TIdent_Typeded but this is + * now done in a fix_tokens style in parsing_hacks_typedef.ml. + *) +let rec lexer_function tr = fun lexbuf -> + match tr.PI.rest with + | [] -> (pr2 "LEXER: ALREADY AT END"; tr.PI.current) + | v::xs -> + tr.PI.rest <- xs; + tr.PI.current <- v; + tr.PI.passed <- v::tr.PI.passed; + + if !Flag.debug_lexer then pr2_gen v; + + if TH.is_comment v + then lexer_function (*~pass*) tr lexbuf + else v + +(* was a define ? *) +let passed_a_define tr = + let xs = tr.PI.passed +> List.rev +> Common.exclude TH.is_comment in + if List.length xs >= 2 + then + (match Common2.head_middle_tail xs with + | T.TDefine _, _, T.TCommentNewline_DefineEndOfMacro _ -> true + | _ -> false + ) + else begin + pr2 "WIERD: length list of error recovery tokens < 2 "; + false + end + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) +(* + * note: as now we go in two passes, there is first all the error message of + * the lexer, and then the error of the parser. It is not anymore + * interwinded. + * + * !!!This function use refs, and is not reentrant !!! so take care. + * It uses the _defs global defined above!!!! + *) +let parse_with_lang ?(lang=Flag_parsing_cpp.Cplusplus) file = + + let stat = Parse_info.default_stat file in + let filelines = Common2.cat_array file in + + (* -------------------------------------------------- *) + (* call lexer and get all the tokens *) + (* -------------------------------------------------- *) + let toks_orig = tokens file in + + let toks = + try Parsing_hacks.fix_tokens ~macro_defs:_defs lang toks_orig + with Token_views_cpp.UnclosedSymbol s -> + pr2 s; + if !Flag.debug_cplusplus + then raise (Token_views_cpp.UnclosedSymbol s) + else toks_orig + in + + let tr = Parse_info.mk_tokens_state toks in + let lexbuf_fake = Lexing.from_function (fun _buf _n -> raise Impossible) in + + let rec loop () = + + let info = TH.info_of_tok tr.PI.current in + (* todo?: I am not sure that it represents current_line, cos maybe + * tr.current partipated in the previous parsing phase, so maybe tr.current + * is not the first token of the next parsing phase. Same with checkpoint2. + * It would be better to record when we have a } or ; in parser.mly, + * cos we know that they are the last symbols of external_declaration2. + *) + let checkpoint = PI.line_of_info info in + (* bugfix: may not be equal to 'file' as after macro expansions we can + * start to parse a new entity from the body of a macro, for instance + * when parsing a define_machine() body, cf standard.h + *) + let checkpoint_file = PI.file_of_info info in + + tr.PI.passed <- []; + (* for some statistics *) + let was_define = ref false in + + let elem = + (try + (* -------------------------------------------------- *) + (* Call parser *) + (* -------------------------------------------------- *) + Parser_cpp.toplevel (lexer_function tr) lexbuf_fake + with e -> + if not !Flag.error_recovery + then raise (Parse_error (TH.info_of_tok tr.PI.current)); + + if !Flag.show_parsing_error then + (match e with + (* Lexical is not anymore launched I think *) + | Lexer.Lexical s -> + pr2 ("lexical error " ^s^ "\n =" ^ error_msg_tok tr.PI.current) + | Parsing.Parse_error -> + pr2 ("parse error \n = " ^ error_msg_tok tr.PI.current) + | Semantic.Semantic (s, _i) -> + pr2 ("semantic error " ^s^ "\n ="^ error_msg_tok tr.PI.current) + | e -> raise e + ); + + let line_error = TH.line_of_tok tr.PI.current in + + let pbline = + tr.PI.passed + +> List.filter (is_same_line_or_close line_error) + +> List.filter TH.is_ident_like + in + let error_info = + (pbline +> List.map (fun tok->PI.str_of_info (TH.info_of_tok tok))), + line_error + in + stat.Stat.problematic_lines <- + error_info::stat.Stat.problematic_lines; + + (* error recovery, go to next synchro point *) + let (passed', rest') = + Parsing_recovery_cpp.find_next_synchro tr.PI.rest tr.PI.passed in + tr.PI.rest <- rest'; + tr.PI.passed <- passed'; + + tr.PI.current <- List.hd passed'; + + (* <> line_error *) + let info = TH.info_of_tok tr.PI.current in + let checkpoint2 = PI.line_of_info info in + let checkpoint2_file = PI.file_of_info info in + + was_define := passed_a_define tr; + (if !was_define && !Flag.filter_define_error + then () + else + (* bugfix: *) + (if (checkpoint_file = checkpoint2_file) && checkpoint_file = file + then PI.print_bad line_error (checkpoint, checkpoint2) filelines + else pr2 "PB: bad: but on tokens not from original file" + ) + ); + + let info_of_bads = + Common2.map_eff_rev TH.info_of_tok tr.PI.passed in + + Some (Ast.NotParsedCorrectly info_of_bads) + ) + in + + (* again not sure if checkpoint2 corresponds to end of bad region *) + let info = TH.info_of_tok tr.PI.current in + let checkpoint2 = PI.line_of_info info in + let checkpoint2_file = PI.file_of_info info in + + let diffline = + if (checkpoint_file = checkpoint2_file) && (checkpoint_file = file) + then (checkpoint2 - checkpoint) + else 0 + (* TODO? so if error come in middle of something ? where the + * start token was from original file but synchro found in body + * of macro ? then can have wrong number of lines stat. + * Maybe simpler just to look at tr.passed and count + * the lines in the token from the correct file ? + *) + in + let info = List.rev tr.PI.passed in + + (* some stat updates *) + stat.Stat.commentized <- + stat.Stat.commentized + count_lines_commentized info; + (match elem with + | Some (Ast.NotParsedCorrectly _xs) -> + if !was_define && !Flag.filter_define_error + then stat.Stat.commentized <- stat.Stat.commentized + diffline + else stat.Stat.bad <- stat.Stat.bad + diffline + + | _ -> stat.Stat.correct <- stat.Stat.correct + diffline + ); + + (match elem with + | None -> [] + | Some xs -> (xs, info):: loop () (* recurse *) + ) + in + let v = loop() in + (v, stat) + +let parse2 file = + match File_type.file_type_of_file file with + | FT.PL (FT.C _) -> + (try + parse_with_lang ~lang:Flag.C file + with _exn -> + parse_with_lang ~lang:Flag.Cplusplus file + ) + | FT.PL (FT.Cplusplus _) -> + parse_with_lang ~lang:Flag.Cplusplus file + | _ -> failwith (spf "not a C/C++ file: %s" file) + + +let parse file = + Common.profile_code "Parse_cpp.parse" (fun () -> + try + parse2 file + with Stack_overflow -> + pr2 (spf "PB stack overflow in %s" file); + [(Ast.NotParsedCorrectly [], ([]))], {Stat. + correct = 0; + bad = Common2.nblines_with_wc file; + filename = file; + have_timeout = true; + commentized = 0; + problematic_lines = []; + } + ) + +let parse_program file = + let (ast2, _stat) = parse file in + program_of_program2 ast2 diff --git a/lang_cpp/parsing/parse_cpp.mli b/lang_cpp/parsing/parse_cpp.mli new file mode 100644 index 0000000..f369022 --- /dev/null +++ b/lang_cpp/parsing/parse_cpp.mli @@ -0,0 +1,43 @@ + +(* the token list contains also the comment-tokens *) +type toplevels_and_tokens = (Ast_cpp.toplevel * Parser_cpp.token list) list + +(* actually covers Lexical, Parsing, and Semantic errors *) +exception Parse_error of Parse_info.info + +(* This is the main function. It uses _defs below which often comes + * from a standard.h macro file. It will raise Parse_error unless + * Flag_parsing_cpp.error_recovery is set. + *) +val parse: + Common.filename -> (toplevels_and_tokens * Parse_info.parsing_stat) + +val parse_program: + Common.filename -> Ast_cpp.program +val parse_with_lang: + ?lang:Flag_parsing_cpp.language -> + Common.filename -> (toplevels_and_tokens * Parse_info.parsing_stat) + +val parse_fuzzy: + Common.filename -> Ast_fuzzy.tree list * Parser_cpp.token list + +(* usually correspond to what is inside your macros.h *) +val _defs : (string, Pp_token.define_body) Hashtbl.t +val init_defs : Common.filename -> unit +val add_defs : Common.filename -> unit +(* used to extract macros from standard.h, but also now used on C files + * in -extract_macros to assist in building a macros.h + *) +val extract_macros: + Common.filename -> (string, Pp_token.define_body) Common.assoc + +(* usually correspond to what is inside your standard.h *) +(* val _defs_builtins : (string, Cpp_token_c.define_def) Hashtbl.t ref *) +(* todo: init_defs_macros and init_defs_builtins *) + +(* subsystem testing *) +val tokens: Common.filename -> Parser_cpp.token list + +(* a few helpers *) +val program_of_program2: toplevels_and_tokens -> Ast_cpp.program + diff --git a/lang_cpp/parsing/parser_cpp.mly b/lang_cpp/parsing/parser_cpp.mly new file mode 100644 index 0000000..be7b1b6 --- /dev/null +++ b/lang_cpp/parsing/parser_cpp.mly @@ -0,0 +1,1975 @@ +%{ +(* Yoann Padioleau + * + * Copyright (C) 2010-2014 Facebook + * Copyright (C) 2008-2009 University of Urbana Champaign + * Copyright (C) 2006-2007 Ecole des Mines de Nantes + * Copyright (C) 2002 Yoann Padioleau + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +open Ast_cpp +open Parser_cpp_mly_helper + +(* see todo_mly for stuff temporarily commented out *) + +%} + +/*(*************************************************************************)*/ +/*(*1 Tokens *)*/ +/*(*************************************************************************)*/ +/* +(* Some tokens below are not even used in this file because they are filtered + * in some intermediate phases (e.g. the comment tokens). Some tokens + * also appear only here and are not in the lexer because they are + * created in some intermediate phases. They are called "fresh" tokens + * and always contain a '_' in their name. + *)*/ + +/*(* unrecognized token, will generate parse error *)*/ +%token TUnknown + +%token EOF + +/*(*-----------------------------------------*)*/ +/*(*2 The space/comment tokens *)*/ +/*(*-----------------------------------------*)*/ +/* +(* coupling: Token_helpers.is_real_comment and other related functions. + * disappear in parse_cpp.ml via TH.is_comment in lexer_function + *)*/ +%token TCommentSpace TCommentNewline TComment + +/*(* fresh_token: cppext: appears after parsing_hack_pp and disappear *)*/ +%token <(Token_cpp.cppcommentkind * Parse_info.info)> TComment_Pp +/*(* fresh_token: c++ext: appears after parsing_hack_pp and disappear *)*/ +%token <(Token_cpp.cpluspluscommentkind * Parse_info.info)> TComment_Cpp + +/*(*-----------------------------------------*)*/ +/*(*2 The C tokens *)*/ +/*(*-----------------------------------------*)*/ + +%token TInt +%token <(string * Ast_cpp.floatType) * Parse_info.info> TFloat +%token <(string * Ast_cpp.isWchar) * Parse_info.info> TChar TString + +%token TIdent +/*(* fresh_token: appear after some fix_tokens in parsing_hack.ml *)*/ +%token TIdent_Typedef + +/* +(* coupling: some tokens like TOPar and TCPar are used as synchronisation point + * in parsing_hack.ml. So if you define a special token like TOParDefine and + * TCParEOL, then you must take care to also modify token_helpers.ml + *)*/ +%token TOPar TCPar TOBrace TCBrace TOCro TCCro + +%token TDot TComma TPtrOp TInc TDec +%token TAssign +%token TEq TWhy TTilde TBang TEllipsis TCol TPtVirg +%token + TOrLog TAndLog TOr TXor TAnd TEqEq TNotEq TInfEq TSupEq + TShl TShr + TPlus TMinus TMul TDiv TMod + +/*(*c++ext: see also TInf2 and TSup2 *)*/ +%token TInf TSup + +%token + Tchar Tshort Tint Tdouble Tfloat Tlong Tunsigned Tsigned Tvoid + Tauto Tregister Textern Tstatic + Ttypedef + Tconst Tvolatile + Tstruct Tunion Tenum + Tbreak Telse Tswitch Tcase Tcontinue Tfor Tdo Tif Twhile Treturn + Tgoto Tdefault + Tsizeof + +/*(* C99 *)*/ +%token Trestrict + +/*(*-----------------------------------------*)*/ +/*(*2 gccext: extra tokens *)*/ +/*(*-----------------------------------------*)*/ +%token Tasm Ttypeof +/*(* less: disappear in parsing_hacks_pp, not present in AST for now *)*/ +%token Tattribute +/*(* also c++ext: *)*/ +%token Tinline + +/*(*-----------------------------------------*)*/ +/*(*2 cppext: extra tokens *)*/ +/*(*-----------------------------------------*)*/ + +/*(* cppext: #define *)*/ +%token TDefine +%token <(string * Parse_info.info)> TDefParamVariadic +/*(* transformed in TCommentSpace and disappear in parsing_hack.ml *)*/ +%token TCppEscapedNewline +/*(* fresh_token: appear after fix_tokens_define in parsing_hack_define.ml *)*/ +%token <(string * Parse_info.info)> TIdent_Define +%token TOPar_Define +%token TCommentNewline_DefineEndOfMacro +%token TOBrace_DefineInit + +/*(* cppext: #include *)*/ +%token <(string * string * Parse_info.info)> TInclude + +/*(* cppext: #ifdef *)*/ +/*(* coupling: Token_helpers.is_cpp_instruction *)*/ +%token TIfdef TIfdefelse TIfdefelif TEndif +%token <(bool * Parse_info.info)> TIfdefBool TIfdefMisc TIfdefVersion + +/*(* cppext: other *)*/ +%token TUndef +%token TCppDirectiveOther + +/*(* cppext: special macros *)*/ +/*(* fresh_token: appear after fix_tokens in parsing_hacks_pp.ml *)*/ +%token TIdent_MacroStmt +%token TIdent_MacroString +%token <(string * Parse_info.info)> TIdent_MacroIterator +%token <(string * Parse_info.info)> TIdent_MacroDecl +%token Tconst_MacroDeclConst + +/*(* fresh_token: appear after parsing_hack_pp.ml, alt to TIdent_MacroTop *)*/ +%token TCPar_EOL +/*(* fresh_token: appear after parsing_hack_pp.ml *)*/ +%token TAny_Action + +/*(*-----------------------------------------*)*/ +/*(*2 c++ext: extra tokens *)*/ +/*(*-----------------------------------------*)*/ +%token + Tclass Tthis + Tnew Tdelete + Ttemplate Ttypeid Ttypename + Tcatch Ttry Tthrow + Toperator + Tpublic Tprivate Tprotected Tfriend + Tvirtual + Tnamespace Tusing + Tbool Tfalse Ttrue + Twchar_t + Tconst_cast Tdynamic_cast Tstatic_cast Treinterpret_cast + Texplicit Tmutable + Texport +%token TPtrOpStar TDotStar + +%token TColCol + +/*(* fresh_token: for constructed object, in parsing_hacks_cpp.ml *)*/ +%token TOPar_CplusplusInit +/*(* fresh_token: for template *)*/ +%token TInf_Template TSup_Template +/*(* fresh_token: for new[] delete[] *)*/ +%token TOCro_new TCCro_new +/*(* fresh_token: for pure virtual method. TODO add stuff in parsing_hack *)*/ +%token TInt_ZeroVirtual +/*(* fresh_token: why can't use TypedefIdent? conflict? *)*/ +%token TIdent_ClassnameInQualifier +/*(* fresh_token: appears after solved if next token is a typedef *)*/ +%token TIdent_ClassnameInQualifier_BeforeTypedef +/*(* fresh_token: just before <> *)*/ +%token TIdent_Templatename +/*(* for templatename as qualifier, before a '::' TODO write heuristic! *)*/ +%token TIdent_TemplatenameInQualifier +/*(* fresh_token: appears after solved if next token is a typedef *)*/ +%token TIdent_TemplatenameInQualifier_BeforeTypedef +/*(* fresh_token: for methods with same name as classname *)*/ +%token TIdent_Constructor +/*(* for cast_constructor, before a '(', unused for now *)*/ +%token TIdent_TypedefConstr +/*(* fresh_token: for constructed (basic) objects *)*/ +%token + Tchar_Constr Tint_Constr Tfloat_Constr Tdouble_Constr Twchar_t_Constr + Tshort_Constr Tlong_Constr Tbool_Constr + Tsigned_Constr Tunsigned_Constr +/*(* fresh_token: appears after solved if next token is a typedef *)*/ +%token TColCol_BeforeTypedef + +/*(*************************************************************************)*/ +/*(*1 Priorities *)*/ +/*(*************************************************************************)*/ +/*(* must be at the top so that it has the lowest priority *)*/ +%nonassoc LOW_PRIORITY_RULE +/*(* see conflicts.txt *)*/ +%nonassoc Telse + + +%left TOrLog +%left TAndLog +%left TOr +%left TXor +%left TAnd +%left TEqEq TNotEq +%left TInf TSup TInfEq TSupEq +%left TShl TShr +%left TPlus TMinus +%left TMul TDiv TMod + +/*(*************************************************************************)*/ +/*(*1 Rules type declaration *)*/ +/*(*************************************************************************)*/ +%start main toplevel statement expr type_id + +%type main +%type toplevel +%type statement +%type expr +%type type_id +%type <(Ast_cpp.name) * (Ast_cpp.fullType -> Ast_cpp.fullType)> declarator +%type <(Ast_cpp.name)> type_cplusplus_id +%% + +/*(*************************************************************************)*/ +/*(*1 TOC *)*/ +/*(*************************************************************************)*/ +/* +(* translation_unit (obsolete) + * + * ident + * expression + * statement + * types with + * - left part (type_spec, qualif, template and its arguments), + * - right part (declarator, abstract declarator) + * - aux part (parameters) + * class/struct + * enum + * declaration, storage, initializers + * block_declaration + * cpp directives + * toplevel (= start grammar rule) + * + * generic workarounds (obrace, cbrace for context setting) + * xxx_list, xxx_opt + *)*/ +/*(*************************************************************************)*/ +/*(*1 translation_unit (unused) *)*/ +/*(*************************************************************************)*/ + +/*(* no more used now that use error recovery, but good to keep *)*/ +main: + | translation_unit EOF { $1 } + +translation_unit: + | external_declaration { [DeclElem $1] } + | translation_unit external_declaration { $1 @ [DeclElem $2] } + +external_declaration: + | function_definition { Func (FunctionOrMethod $1) } + | block_declaration { BlockDecl $1 } + +/*(*************************************************************************)*/ +/*(*1 Ident, scope *)*/ +/*(*************************************************************************)*/ + +id_expression: + | unqualified_id { noQscope, $1 } + | qualified_id { $1 } + +/* +(* todo: + * ~id class_name, conflict IdDestructor TODO + * template-id, conflict + *)*/ +unqualified_id: + | TIdent { IdIdent $1 } + | operator_function_id { $1 } + | conversion_function_id { $1 } + +operator_function_id: + | Toperator operator_kind + { IdOperator ($1, $2) } + +conversion_function_id: + | Toperator conversion_type_id + { IdConverter ($1, $2) } +/* +(* no deref getref operator (cos ambiguity with Mul and And), + * no unaryplus/minus op either + *)*/ +operator_kind: + /*(* != == *)*/ + | TEqEq { BinaryOp (Logical Eq), [$1] } + | TNotEq { BinaryOp (Logical NotEq), [$1] } + /*(* = += -= *= /= %= ^= &= |= >>= <<= *)*/ + | TEq { AssignOp SimpleAssign, [$1] } + | TAssign { AssignOp (fst $1), [snd $1] } + /*(* ! ~ *)*/ + | TTilde { UnaryTildeOp, [$1] } + | TBang { UnaryNotOp, [$1] } + /*(* , *)*/ + | TComma { CommaOp, [$1] } + /*(* + - * / % *)*/ + | TPlus { BinaryOp (Arith Plus), [$1] } + | TMinus { BinaryOp (Arith Minus), [$1] } + | TMul { BinaryOp (Arith Mul), [$1] } + | TDiv { BinaryOp (Arith Div), [$1] } + | TMod { BinaryOp (Arith Mod), [$1] } + /*(* ^ & | << >> *)*/ + | TOr { BinaryOp (Arith Or), [$1] } + | TXor { BinaryOp (Arith Xor), [$1] } + | TAnd { BinaryOp (Arith And), [$1] } + | TShl { BinaryOp (Arith DecLeft), [$1] } + | TShr { BinaryOp (Arith DecRight), [$1] } + /*(* && || *)*/ + | TOrLog { BinaryOp (Logical OrLog), [$1] } + | TAndLog { BinaryOp (Logical AndLog), [$1] } + /*(* < > <= >= *)*/ + | TInf { BinaryOp (Logical Inf), [$1] } + | TSup { BinaryOp (Logical Sup), [$1] } + | TInfEq { BinaryOp (Logical InfEq), [$1] } + | TSupEq { BinaryOp (Logical SupEq), [$1] } + /*(* ++ -- *)*/ + | TInc { FixOp Inc, [$1] } + | TDec { FixOp Dec, [$1] } + /*(* ->* -> *) */ + | TPtrOpStar { PtrOpOp PtrStarOp, [$1] } + | TPtrOp { PtrOpOp PtrOp, [$1] } + /*(* () [] (double tokens) *)*/ + | TOPar TCPar { AccessOp ParenOp, [$1;$2] } + | TOCro TCCro { AccessOp ArrayOp, [$1;$2] } + /*(* new delete *)*/ + | Tnew { AllocOp NewOp, [$1] } + | Tdelete { AllocOp DeleteOp, [$1] } + /*(*new[] delete[] (tripple tokens) *)*/ + | Tnew TOCro_new TCCro_new { AllocOp NewArrayOp, [$1;$2;$3] } + | Tdelete TOCro_new TCCro_new { AllocOp DeleteArrayOp, [$1;$2;$3] } + + + +qualified_id: + | nested_name_specifier /*(*templateopt*)*/ unqualified_id + { $1, $2 } + +nested_name_specifier: + | class_or_namespace_name_for_qualifier TColCol nested_name_specifier_opt + { ($1, $2)::$3 } + +/*(* context dependent *)*/ +class_or_namespace_name_for_qualifier: + | TIdent_ClassnameInQualifier + { QClassname $1 } + | TIdent_TemplatenameInQualifier + TInf_Template template_argument_list TSup_Template + { QTemplateId ($1, ($2, $3, $4)) } + + +/* +(* context dependent: in the original grammar there was one rule + * for each names (e.g. typedef_name:, enum_name:, class_name:) but + * we don't have such contextual information and we can merge + * those rules anyway without introducing conflicts. + *)*/ +enum_name_or_typedef_name_or_simple_class_name: + | TIdent_Typedef { $1 } +/*(* used only with namespace/using rules. We use Tclassname for stuff + * like std::... todo? or just TIdent_Typedef? *)*/ +namespace_name: + | TIdent { $1 } + +/*(*----------------------------*)*/ +/*(*2 workarounds *)*/ +/*(*----------------------------*)*/ +nested_name_specifier2: + | class_or_namespace_name_for_qualifier2 + TColCol_BeforeTypedef nested_name_specifier_opt2 + { ($1, $2)::$3 } + +class_or_namespace_name_for_qualifier2: + | TIdent_ClassnameInQualifier_BeforeTypedef + { QClassname $1 } + | TIdent_TemplatenameInQualifier_BeforeTypedef + TInf_Template template_argument_list TSup_Template + { QTemplateId ($1, ($2, $3, $4)) } + +/* +(* Why this ? Why not s/ident/TIdent ? cos there is multiple namespaces in C, + * so a label can have the same name that a typedef, same for field and tags + * hence sometimes the use of ident instead of TIdent. + *)*/ +ident: + | TIdent { $1 } + | TIdent_Typedef { $1 } + +/*(*************************************************************************)*/ +/*(*1 Expressions *)*/ +/*(*************************************************************************)*/ + +expr: + | assign_expr { $1 } + | expr TComma assign_expr { mk_e (Sequence ($1,$3)) [$2] } + +/*(* bugfix: in C grammar they put 'unary_expr', but in fact it must be + * 'cast_expr', otherwise (int * ) xxx = &yy; is not allowed + *)*/ +assign_expr: + | cond_expr { $1 } + | cast_expr TAssign assign_expr { mk_e(Assignment ($1,fst $2,$3)) [snd $2]} + | cast_expr TEq assign_expr { mk_e(Assignment ($1,SimpleAssign,$3)) [$2]} + /*(*c++ext: *)*/ + | Tthrow assign_expr_opt { mk_e (Throw $2) [$1] } + +/*(* gccext: allow optional then part hence opt_expr + * bugfix: in C grammar they put 'TCol cond_expr', but in fact it must be + * 'assign_expr', otherwise pnp ? x : x = 0x388 is not allowed + *)*/ +cond_expr: + | arith_expr { $1 } + | arith_expr TWhy expr_opt TCol assign_expr + { mk_e (CondExpr ($1,$3,$5)) [$2;$4] } + + +arith_expr: + | pm_expr { $1 } + | arith_expr TMul arith_expr { mk_e(Binary ($1, Arith Mul, $3)) [$2] } + | arith_expr TDiv arith_expr { mk_e(Binary ($1, Arith Div, $3)) [$2] } + | arith_expr TMod arith_expr { mk_e(Binary ($1, Arith Mod, $3)) [$2] } + + | arith_expr TPlus arith_expr { mk_e(Binary ($1, Arith Plus, $3)) [$2] } + | arith_expr TMinus arith_expr { mk_e(Binary ($1, Arith Minus, $3)) [$2] } + | arith_expr TShl arith_expr { mk_e(Binary ($1, Arith DecLeft, $3)) [$2] } + | arith_expr TShr arith_expr { mk_e(Binary ($1, Arith DecRight, $3)) [$2] } + | arith_expr TInf arith_expr { mk_e(Binary ($1, Logical Inf, $3)) [$2] } + | arith_expr TSup arith_expr { mk_e(Binary ($1, Logical Sup, $3)) [$2] } + | arith_expr TInfEq arith_expr { mk_e(Binary ($1, Logical InfEq, $3)) [$2] } + | arith_expr TSupEq arith_expr { mk_e(Binary ($1, Logical SupEq, $3)) [$2] } + | arith_expr TEqEq arith_expr { mk_e(Binary ($1, Logical Eq, $3)) [$2] } + | arith_expr TNotEq arith_expr { mk_e(Binary ($1, Logical NotEq, $3)) [$2] } + | arith_expr TAnd arith_expr { mk_e(Binary ($1, Arith And, $3)) [$2] } + | arith_expr TOr arith_expr { mk_e(Binary ($1, Arith Or, $3)) [$2] } + | arith_expr TXor arith_expr { mk_e(Binary ($1, Arith Xor, $3)) [$2] } + | arith_expr TAndLog arith_expr { mk_e(Binary ($1, Logical AndLog, $3)) [$2] } + | arith_expr TOrLog arith_expr { mk_e(Binary ($1, Logical OrLog, $3)) [$2] } + +pm_expr: + | cast_expr { $1 } + /*(*c++ext: .* and ->*, note that not next to . and -> and take expr *)*/ + | pm_expr TDotStar cast_expr + { mk_e(RecordStarAccess ($1,$3)) [$2]} + | pm_expr TPtrOpStar cast_expr + { mk_e(RecordPtStarAccess ($1,$3)) [$2]} + +cast_expr: + | unary_expr { $1 } + | TOPar type_id TCPar cast_expr { mk_e(Cast (($1, $2, $3), $4)) noii } + +unary_expr: + | postfix_expr { $1 } + | TInc unary_expr { mk_e(Infix ($2, Inc)) [$1] } + | TDec unary_expr { mk_e(Infix ($2, Dec)) [$1] } + | unary_op cast_expr { mk_e(Unary ($2, fst $1)) [snd $1] } + | Tsizeof unary_expr { mk_e(SizeOfExpr ($1, $2)) noii } + | Tsizeof TOPar type_id TCPar { mk_e(SizeOfType ($1, ($2, $3, $4))) noii } + /*(*c++ext: *)*/ + | new_expr { $1 } + | delete_expr { $1 } + +unary_op: + | TAnd { GetRef, $1 } + | TMul { DeRef, $1 } + | TPlus { UnPlus, $1 } + | TMinus { UnMinus, $1 } + | TTilde { Tilde, $1 } + | TBang { Not, $1 } + /*(* gccext: have that a lot in old kernel to get address of local label. + * cf gcc manual "local labels as values". + *)*/ + | TAndLog { GetRefLabel, $1 } + + +postfix_expr: + | primary_expr { $1 } + | postfix_expr TOCro expr TCCro + { mk_e(ArrayAccess ($1, ($2, $3, $4))) noii } + | postfix_expr TOPar argument_list_opt TCPar + { mk_e(mk_funcall $1 ($2, $3, $4)) noii } + + /*(*c++ext: ident is now a id_expression *)*/ + | postfix_expr TDot template_opt tcolcol_opt id_expression + { let name = ($4, fst $5, snd $5) in mk_e(RecordAccess ($1,name)) [$2] } + | postfix_expr TPtrOp template_opt tcolcol_opt id_expression + { let name = ($4, fst $5, snd $5) in mk_e(RecordPtAccess($1,name)) [$2] } + + | postfix_expr TInc { mk_e(Postfix ($1, Inc)) [$2] } + | postfix_expr TDec { mk_e(Postfix ($1, Dec)) [$2] } + + /*(* gccext: also called compound literals *)*/ + | compound_literal_expr { $1 } + + /*(* c++ext: *)*/ + | cast_operator_expr { $1 } + | Ttypeid TOPar unary_expr TCPar { mk_e(TypeId ($1, ($2, Right $3, $4))) noii } + | Ttypeid TOPar type_id TCPar { mk_e(TypeId ($1, ($2, Left $3, $4))) noii } + | cast_constructor_expr { $1 } + + +primary_expr: + /*(*c++ext: cf below now. old: TIdent { mk_e(Ident (fst $1)) [snd $1] } *)*/ + + /*(* constants a.k.a literal *)*/ + | TInt { mk_e(C (Int (fst $1))) [snd $1] } + | TFloat { mk_e(C (Float (fst $1))) [snd $1] } + | TString { mk_e(C (String (fst $1))) [snd $1] } + | TChar { mk_e(C (Char (fst $1))) [snd $1] } + /*(*c++ext: *)*/ + | Ttrue { mk_e(C (Bool false)) [$1] } + | Tfalse { mk_e(C (Bool false)) [$1] } + + /*(* forunparser: *)*/ + | TOPar expr TCPar { mk_e(ParenExpr ($1, $2, $3)) noii } + + /*(* gccext: cppext: *)*/ + | string_elem string_list { mk_e(C (MultiString)) ($1 @ $2) } + /*(* gccext: allow statement as expressions via ({ statement }) *)*/ + | TOPar compound TCPar { mk_e(StatementExpr ($1, $2, $3)) noii } + + /*(* c++ext: *)*/ + | Tthis { mk_e(This $1) [] } + /*(* contains identifier rule *)*/ + | primary_cplusplus_id { $1 } + +/*(*----------------------------*)*/ +/*(*2 c++ext: *)*/ +/*(*----------------------------*)*/ + +/*(* can't factorize with following rule :( + * | tcolcol_opt nested_name_specifier_opt TIdent + *)*/ +primary_cplusplus_id: + | id_expression + { let name = (None, fst $1, snd $1) in + mk_e (Id (name, noIdInfo())) [] } + | TColCol TIdent + { let name = Some $1, noQscope, IdIdent $2 in + mk_e (Id (name, noIdInfo())) [] } + | TColCol operator_function_id + { let qop = $2 in + let name = (Some $1, noQscope, qop) in + mk_e (Id (name, noIdInfo())) [] } + | TColCol qualified_id + { let name = (Some $1, fst $2, snd $2) in + mk_e (Id (name, noIdInfo())) [] } + +/*(*could use TInf here *)*/ +cast_operator_expr: + | cpp_cast_operator TInf_Template type_id TSup_Template TOPar expr TCPar + { mk_e (CplusplusCast ($1, ($2, $3, $4), ($5, $6, $7))) noii } +/*(* TODO: remove once we don't skip template arguments *)*/ + | cpp_cast_operator TOPar expr TCPar + { mk_e ExprTodo noii } + +/*(*c++ext:*)*/ +cpp_cast_operator: + | Tstatic_cast { Static_cast, $1 } + | Tdynamic_cast { Dynamic_cast, $1 } + | Tconst_cast { Const_cast, $1 } + | Treinterpret_cast { Reinterpret_cast, $1 } + +/* +(* c++ext: cast with function syntax, and also constructor, but conflict + * hence the TIdent_TypedefConstr. But it's simpler to just consider + * this as a function call. A semantic analysis could infer it was + * actually a ConstructedObject. + * + * TODO: can have nested specifier before the typedefident ... so + * need a classname3? +*)*/ +cast_constructor_expr: + | TIdent_TypedefConstr TOPar argument_list_opt TCPar + { let name = None, noQscope, IdIdent $1 in + let ft = nQ, (TypeName name, noii) in + mk_e(ConstructedObject (ft, ($2, $3, $4))) noii + } + | basic_type_2 TOPar argument_list_opt TCPar + { let ft = nQ, $1 in + mk_e(ConstructedObject (ft, ($2, $3, $4))) noii + } + +/*(* c++ext: * simple case: new A(x1, x2); *)*/ +new_expr: + | tcolcol_opt Tnew new_placement_opt new_type_id new_initializer_opt + { mk_e (New ($1, $2, $3, $4, $5)) noii } +/*(* ambiguity then on the TOPar + tcolcol_opt Tnew new_placement_opt TOPar type_id TCPar new_initializer_opt + *)*/ + +delete_expr: + | tcolcol_opt Tdelete cast_expr + { mk_e (Delete ($1, $3)) [$2] } + | tcolcol_opt Tdelete TOCro_new TCCro_new cast_expr + { mk_e (DeleteArray ($1, $5)) [$2;$3;$4] } + +new_placement: + | TOPar argument_list TCPar { ($1, $2, $3) } + +new_initializer: + | TOPar argument_list_opt TCPar { ($1, $2, $3) } + +/*(*----------------------------*)*/ +/*(*2 gccext: *)*/ +/*(*----------------------------*)*/ + +compound_literal_expr: + | TOPar type_id TCPar TOBrace TCBrace + { mk_e(GccConstructor (($1, $2, $3), ($4, [], $5))) noii } + | TOPar type_id TCPar TOBrace initialize_list gcc_comma_opt TCBrace + { mk_e(GccConstructor (($1, $2, $3), ($4, List.rev $5, $7))) noii } + +string_elem: + | TString { [snd $1] } + /*(* cppext: ex= printk (KERN_INFO "xxx" UTS_RELEASE) *)*/ + | TIdent_MacroString { [$1] } + +/*(*----------------------------*)*/ +/*(*2 cppext: *)*/ +/*(*----------------------------*)*/ + +argument: + | assign_expr { Left $1 } +/*(* cppext: *)*/ +/*(* actually this can happen also when have a wrong typedef inference ...*)*/ + | type_id { Right (ArgType $1) } +/* see todo_mly */ + +/*(*----------------------------*)*/ +/*(*2 workarounds *)*/ +/*(*----------------------------*)*/ + +/*(* would like evalInt $1 but require too much info *)*/ +const_expr: cond_expr { $1 } + +basic_type_2: + | Tchar_Constr { (BaseType (IntType CChar)), [$1]} + | Tint_Constr { (BaseType (IntType (Si (Signed,CInt)))), [$1]} + | Tfloat_Constr { (BaseType (FloatType CFloat)), [$1]} + | Tdouble_Constr { (BaseType (FloatType CDouble)), [$1] } + + | Twchar_t_Constr { (BaseType (IntType WChar_t)), [$1] } + + | Tshort_Constr { (BaseType (IntType (Si (Signed, CShort)))), [$1] } + | Tlong_Constr { (BaseType (IntType (Si (Signed, CLong)))), [$1] } + | Tbool_Constr { (BaseType (IntType CBool)), [$1] } + +/*(*************************************************************************)*/ +/*(*1 Statements *)*/ +/*(*************************************************************************)*/ + +statement: + | compound { Compound $1, noii } + | expr_statement { ExprStatement(fst $1), snd $1 } + | labeled { Labeled (fst $1), snd $1 } + | selection { Selection (fst $1), snd $1 } + | iteration { Iteration (fst $1), snd $1 } + | jump TPtVirg { Jump (fst $1), snd $1 @ [$2] } + + /*(* cppext: *)*/ + | TIdent_MacroStmt { MacroStmt, [$1] } + + /* + (* cppext: c++ext: because of cpp, some stuff looks like declaration but are in + * fact statement but too hard to figure out, and if parse them as + * expression, then we force to have first decls and then exprs, then + * will have a parse error. So easier to let mix decl/statement. + * Moreover it helps to not make such a difference between decl and + * statement for further coccinelle phases to factorize code. + * + * update: now a c++ext and handle slightly differently. It's inlined + * in statement instead of going through a stat_or_decl. + *)*/ + | declaration_statement { $1 } + + /*(* gccext: if move in statement then can have r/r conflict with define *)*/ + | function_definition { NestedFunc $1, noii } + + /*(* c++ext: *)*/ + | try_block { $1 } + + +compound: + | TOBrace statement_list_opt TCBrace { ($1, $2, $3) } + + +expr_statement: + | expr_opt TPtVirg { $1, [$2] } + +/*(* note that case 1: case 2: i++; would be correctly parsed, but with + * a Case (1, (Case (2, i++))) :( + *)*/ +labeled: + | ident TCol statement { Label (fst $1, $3), [snd $1; $2] } + | Tcase const_expr TCol statement { Case ($2, $4), [$1; $3] } + | Tcase const_expr TEllipsis const_expr TCol statement + { CaseRange ($2, $4, $6), [$1;$3;$5] } /*(* gccext: allow range *)*/ + | Tdefault TCol statement { Default $3, [$1; $2] } + +/*(* classic else ambiguity resolved by a %prec, see conflicts.txt *)*/ +selection: + | Tif TOPar expr TCPar statement %prec LOW_PRIORITY_RULE + { If ($1, ($2, $3, $4), $5, None, (ExprStatement None, [])), noii } + | Tif TOPar expr TCPar statement Telse statement + { If ($1, ($2, $3, $4), $5, Some $6, $7), noii } + | Tswitch TOPar expr TCPar statement + { Switch ($1, ($2, $3, $4), $5), noii } + +iteration: + | Twhile TOPar expr TCPar statement + { While ($1, ($2, $3, $4), $5), noii } + | Tdo statement Twhile TOPar expr TCPar TPtVirg + { DoWhile ($1, $2, $3, ($4, $5, $6), $7), noii } + | Tfor TOPar expr_statement expr_statement expr_opt TCPar statement + { For ($1, ($2, ($3,$4, ($5, [])), $6), $7), noii } + /*(* cppext: *)*/ + | TIdent_MacroIterator TOPar argument_list_opt TCPar statement + { MacroIteration ($1, ($2, $3, $4), $5), noii } + +/*(* the ';' in the caller grammar rule will be appended to the infos *)*/ +jump: + | Tgoto ident { Goto (fst $2), [$1;snd $2] } + | Tcontinue { Continue, [$1] } + | Tbreak { Break, [$1] } + | Treturn { Return, [$1] } + | Treturn expr { ReturnExpr $2, [$1] } + | Tgoto TMul expr { GotoComputed $3, [$1;$2] } + + +/*(*----------------------------*)*/ +/*(*2 cppext: *)*/ +/*(*----------------------------*)*/ + +statement_list_opt: + | /*(*empty*)*/ { [] } + | statement_list { $1 } + +statement_list: + | statement_seq { [$1] } + | statement_list statement_seq { $1 @ [$2] } + +statement_seq: + | statement { StmtElem $1 } + /*(* cppext: *)*/ + | cpp_directive + { CppDirectiveStmt $1 } + | cpp_ifdef_directive/*(* stat_or_decl_list ...*)*/ + { IfdefStmt $1 } + +/*(*----------------------------*)*/ +/*(*2 c++ext: *)*/ +/*(*----------------------------*)*/ + +declaration_statement: + | block_declaration { DeclStmt $1, noii } + +try_block: + | Ttry compound handler_list { Try ($1, $2, $3), noii } + +handler: + | Tcatch TOPar exception_decl TCPar compound { ($1, ($2, $3, $4), $5) } + +exception_decl: + | parameter_decl { ExnDecl $1 } + | TEllipsis { ExnDeclEllipsis $1 } + +/*(*************************************************************************)*/ +/*(*1 Types *)*/ +/*(*************************************************************************)*/ + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 Type spec, left part of a type *)*/ +/*(*-----------------------------------------------------------------------*)*/ + +/*(* in c++ grammar they put 'cv_qualifier' here but I prefer keep as before *)*/ +type_spec: + | simple_type_specifier { $1 } + | elaborated_type_specifier { $1 } + | enum_specifier { Right3 $1, noii } + | class_specifier { Right3 (StructDef $1), noii } + + +simple_type_specifier: + | Tvoid { Right3 (BaseType Void), [$1] } + | Tchar { Right3 (BaseType (IntType CChar)), [$1]} + | Tint { Right3 (BaseType (IntType (Si (Signed,CInt)))), [$1]} + | Tfloat { Right3 (BaseType (FloatType CFloat)), [$1]} + | Tdouble { Right3 (BaseType (FloatType CDouble)), [$1] } + | Tshort { Middle3 Short, [$1]} + | Tlong { Middle3 Long, [$1]} + | Tsigned { Left3 Signed, [$1]} + | Tunsigned { Left3 UnSigned, [$1]} + /*(*c++ext: *)*/ + | Tbool { Right3 (BaseType (IntType CBool)), [$1] } + | Twchar_t { Right3 (BaseType (IntType WChar_t)), [$1] } + + /*(* gccext: *)*/ + | Ttypeof TOPar assign_expr TCPar { Right3 (TypeOf ($1,($2,Right $3,$4))),noii} + | Ttypeof TOPar type_id TCPar { Right3 (TypeOf ($1,($2,Left $3,$4))),noii} + + /* + (* history: cant put TIdent {} cos it makes the grammar ambiguous and + * generates lots of conflicts => we must use some tricks. + * See parsing_hacks_typedef.ml. See also conflicts.txt + *)*/ + | type_cplusplus_id { Right3 (TypeName $1), noii } + + +/*(*todo: can have a ::opt nested_name_specifier_opt before ident*)*/ +elaborated_type_specifier: + | Tenum ident + { Right3 (EnumName ($1, $2)), noii } + | class_key ident + { Right3 (StructUnionName ($1, $2)), noii } + /*(* c++ext: *)*/ + | Ttypename type_cplusplus_id + { Right3 (TypenameKwd ($1, $2)), noii } + +/*(*----------------------------*)*/ +/*(*2 c++ext: *)*/ +/*(*----------------------------*)*/ + +/*(* cant factorize with a tcolcol_opt2 *)*/ +type_cplusplus_id: + | type_name { None, noQscope, $1 } + | nested_name_specifier2 type_name { None, $1, $2 } + | TColCol_BeforeTypedef type_name { Some $1, noQscope, $2 } + | TColCol_BeforeTypedef nested_name_specifier2 type_name + { Some $1, $2, $3 } + +/* +(* in c++ grammar they put + * typename: enum-name | typedef-name | class-name + * class-name: identifier | template-id + * template-id: template-name < template-argument-list > + * + * But in my case I don't have the contextual info so when I see an ident + * it can be a typedef-name, enum-name, or class-name (but not template-name + * because I detect them as they have a '<' just after), + * so here type_name is simplified in consequence. + *)*/ +type_name: + | enum_name_or_typedef_name_or_simple_class_name { IdIdent $1 } + | template_id { $1 } + +template_id: + | TIdent_Templatename TInf_Template template_argument_list TSup_Template + { IdTemplateId ($1, ($2, $3, $4)) } + +/* +(*c++ext: in the c++ grammar they have also 'template-name' but this is catched + * in my case by type_id and its generic TypedefIdent, or will be parsed + * as an Ident and so assign_expr. In this later case may need a ast post + * disambiguation analysis for some false positive. + *)*/ +template_argument: + | type_id { Left $1 } + | assign_expr { Right $1 } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 Qualifiers *)*/ +/*(*-----------------------------------------------------------------------*)*/ + +/*(* was called type_qualif before *)*/ +cv_qualif: + | Tconst { {const=Some $1; volatile=None} } + | Tvolatile { {const=None ; volatile=Some $1} } + /*(* C99 *)*/ + | Trestrict { (* TODO *) {const=None ; volatile=None} } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 Declarator, right part of a type + second part of decl (the ident) *)*/ +/*(*-----------------------------------------------------------------------*)*/ +/* +(* declarator return a couple: + * (name, partial type (a function to be applied to return type)) + * + * note that with 'int* f(int)' we must return Func(Pointer int,int) and not + * Pointer (Func(int,int)). + *)*/ + +declarator: + | pointer direct_d { (fst $2, fun x -> x +> $1 +> (snd $2) ) } + | direct_d { $1 } + +/*(* so must do int * const p; if the pointer is constant, not the pointee *)*/ +pointer: + | TMul { fun x ->(nQ, (Pointer x, [$1]))} + | TMul cv_qualif_list { fun x ->($2.qualifD, (Pointer x, [$1]))} + | TMul pointer { fun x ->(nQ, (Pointer ($2 x),[$1]))} + | TMul cv_qualif_list pointer { fun x ->($2.qualifD, (Pointer ($3 x),[$1]))} + /*(*c++ext: no qualif for ref *)*/ + | TAnd { fun x ->(nQ, (Reference x, [$1]))} + | TAnd pointer { fun x ->(nQ, (Reference ($2 x),[$1]))} + +direct_d: + | declarator_id + { ($1, fun x -> x) } + | TOPar declarator TCPar /*(* forunparser: old: $2 *)*/ + { (fst $2, fun x -> (nQ, (ParenType ($1, (snd $2) x, $3), noii))) } + | direct_d TOCro TCCro + { (fst $1, fun x->(snd $1) (nQ,(Array (($2,None,$3),x), noii))) } + | direct_d TOCro const_expr TCCro + { (fst $1, fun x->(snd $1) (nQ,(Array (($2, Some $3, $4),x),noii))) } + | direct_d TOPar TCPar const_opt exn_spec_opt + { (fst $1, fun x-> (snd $1) + (nQ, (FunctionType { + ft_ret= x; ft_params = ($2, [], $3); + ft_dots = None; ft_const = $4; ft_throw = $5; }, noii))) + } + | direct_d TOPar parameter_type_list TCPar const_opt exn_spec_opt + { (fst $1, fun x-> (snd $1) + (nQ,(FunctionType { + ft_ret = x; ft_params = ($2,fst $3,$4); + ft_dots = snd $3; ft_const = $5; ft_throw = $6; }, noii))) + } + +/*(*----------------------------*)*/ +/*(*2 c++ext: *)*/ +/*(*----------------------------*)*/ +declarator_id: + | tcolcol_opt id_expression + { ($1, fst $2, snd $2) } +/*(* TODO ::opt nested-name-specifieropt type-name*) */ + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 Abstract Declarator (right part of a type, no ident) *)*/ +/*(*-----------------------------------------------------------------------*)*/ +abstract_declarator: + | pointer { $1 } + | direct_abstract_declarator { $1 } + | pointer direct_abstract_declarator { fun x -> x +> $2 +> $1 } + +direct_abstract_declarator: + | TOPar abstract_declarator TCPar /*(* forunparser: old: $2 *)*/ + { (fun x -> (nQ, (ParenType ($1, $2 x, $3), noii))) } + | TOCro TCCro + { fun x -> (nQ, (Array (($1,None, $2), x), noii))} + | TOCro const_expr TCCro + { fun x -> (nQ, (Array (($1, Some $2, $3), x), noii))} + | direct_abstract_declarator TOCro TCCro + { fun x ->$1 (nQ, (Array (($2, None, $3), x), noii)) } + | direct_abstract_declarator TOCro const_expr TCCro + { fun x ->$1 (nQ, (Array (($2, Some $3, $4), x), noii)) } + | TOPar TCPar + { fun x -> (nQ, (FunctionType { + ft_ret = x; ft_params = ($1,[],$2); + ft_dots = None; ft_const = None; ft_throw = None;}, noii)) } + | TOPar parameter_type_list TCPar + { fun x -> (nQ, (FunctionType { + ft_ret = x; ft_params = ($1,fst $2,$3); + ft_dots = snd $2; ft_const = None; ft_throw = None; }, noii)) } + | direct_abstract_declarator TOPar TCPar const_opt exn_spec_opt + { fun x -> $1 (nQ, (FunctionType { + ft_ret = x; ft_params = ($2,[],$3); + ft_dots = None; ft_const = $4; ft_throw = $5; }, noii)) } + | direct_abstract_declarator TOPar parameter_type_list TCPar const_opt + exn_spec_opt + { fun x -> $1 (nQ, (FunctionType { + ft_ret = x; ft_params = ($2,fst $3,$4); + ft_dots = snd $3; ft_const = $5; ft_throw = $6; }, noii)) } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 Parameters (use decl_spec not type_spec just for 'register') *)*/ +/*(*-----------------------------------------------------------------------*)*/ +parameter_type_list: + | parameter_list { $1, None } + | parameter_list TComma TEllipsis { $1, Some ($2,$3) } + +parameter_decl: + | decl_spec declarator + { let (t_ret,reg) = type_and_register_from_decl $1 in + let (name, ftyp) = fixNameForParam $2 in + { p_name = Some name; p_type = ftyp t_ret; + p_register = reg; p_val = None } } + | decl_spec abstract_declarator + { let (t_ret, reg) = type_and_register_from_decl $1 in + { p_name = None; p_type = $2 t_ret; + p_register = reg; p_val = None } } + | decl_spec + { let (t_ret, reg) = type_and_register_from_decl $1 in + { p_name = None; p_type = t_ret; p_register = reg; p_val = None } } + +/*(*c++ext: default parameter value, copy paste *)*/ + | decl_spec declarator TEq assign_expr + { let (t_ret, reg) = type_and_register_from_decl $1 in + let (name, ftyp) = fixNameForParam $2 in + { p_name = Some name; p_type = ftyp t_ret; + p_register = reg; p_val = Some ($3, $4) } } + | decl_spec abstract_declarator TEq assign_expr + { let (t_ret, reg) = type_and_register_from_decl $1 in + { p_name = None; p_type = $2 t_ret; + p_register = reg; p_val = Some ($3, $4) } } + | decl_spec TEq assign_expr + { let (t_ret, reg) = type_and_register_from_decl $1 in + { p_name = None; p_type = t_ret; + p_register = reg; p_val = Some($2,$3) } } + +/*(*----------------------------*)*/ +/*(*2 workarounds *)*/ +/*(*----------------------------*)*/ + +parameter_list: + | parameter_decl2 { [$1, []] } + | parameter_list TComma parameter_decl2 { $1 @ [$3, [$2]] } + +parameter_decl2: + | parameter_decl { $1 } + /*(* when the typedef inference didn't work *)*/ + | TIdent + { + let t = nQ, (TypeName (None, [], IdIdent $1), noii) in + { p_name = None; p_type = t; p_val = None; p_register = None; } + } + +/*(*----------------------------*)*/ +/*(*2 c++ext: *)*/ +/*(*----------------------------*)*/ +/* +(*c++ext: specialisation + * TODO should be type-id-listopt. Also they can have qualifiers! + * need typedef heuristic for throw() but can be also an expression ... + *)*/ +exception_specification: + | Tthrow TOPar TCPar { ($1, ($2, [], $3)) } + | Tthrow TOPar exn_name TCPar { ($1, ($2, [Left $3], $4)) } + | Tthrow TOPar exn_name TComma exn_name TCPar + { ($1, ($2, [Left $3; Right $4; Left $5], $6)) } + +exn_name: ident + { None, [], IdIdent $1 } + +/*(*c++ext: in orig they put cv-qualifier-seqopt but it's never volatile so*)*/ +const_opt: + | Tconst { Some $1 } + | /*(*empty*)*/ { None } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 helper type rules *)*/ +/*(*-----------------------------------------------------------------------*)*/ +/*(* For type_id. No storage here. Was used before for field but + * now structure fields can have storage so fields now use decl_spec. *)*/ +spec_qualif_list: + | type_spec { addTypeD $1 nullDecl } + | cv_qualif { {nullDecl with qualifD = $1} } + | type_spec spec_qualif_list { addTypeD $1 $2 } + | cv_qualif spec_qualif_list { addQualifD $1 $2 } + +/*(* for pointers in direct_declarator and abstract_declarator *)*/ +cv_qualif_list: + | cv_qualif { {nullDecl with qualifD = $1 } } + | cv_qualif_list cv_qualif { addQualifD $2 $1 } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 xxx_type_id *)*/ +/*(*-----------------------------------------------------------------------*)*/ + +/*(* For cast, sizeof, throw. Was called type_name in old C grammar. *)*/ +type_id: + | spec_qualif_list + { let (t_ret, _, _) = type_and_storage_from_decl $1 in t_ret } + | spec_qualif_list abstract_declarator + { let (t_ret, _, _) = type_and_storage_from_decl $1 in $2 t_ret } +/* +(* used for the type passed to new(). + * There is ambiguity with '*' and '&' cos when have new int *2, it can + * be parsed as (new int) * 2 or (new int * ) 2. + * cf p62 of Ellis. So when see a TMul or TAnd don't reduce here, + * shift, hence the prec when are to decide wether or not to enter + * in new_declarator and its leading ptr_operator + *)*/ +new_type_id: + | spec_qualif_list %prec LOW_PRIORITY_RULE + { let (t_ret, _, _) = type_and_storage_from_decl $1 in t_ret } + | spec_qualif_list new_declarator + { let (t_ret, _, _) = type_and_storage_from_decl $1 in (* TODOAST *) t_ret } + +new_declarator: + | ptr_operator new_declarator + { () } + | ptr_operator %prec LOW_PRIORITY_RULE + { () } + | direct_new_declarator + { () } + +ptr_operator: + | TMul { () } + | TAnd { () } + +direct_new_declarator: + | TOCro expr TCCro { () } + | direct_new_declarator TOCro expr TCCro { () } + +/* +(* in c++ grammar they do 'type_spec_seq conversion_declaratoropt'. We + * can not replace with a simple 'type_id' cos here we must not allow + * functionType otherwise there is conflicts on TOPar. + * TODO: right now do simple_type_specifier because conflict + * when do full type_spec. + * type_spec conversion_declaratoropt + * + *)*/ +conversion_type_id: + | simple_type_specifier conversion_declarator + { let tx = addTypeD $1 nullDecl in + let (t_ret, _, _) = type_and_storage_from_decl tx in t_ret + } + | simple_type_specifier %prec LOW_PRIORITY_RULE + { let tx = addTypeD $1 nullDecl in + let (t_ret, _, _) = type_and_storage_from_decl tx in t_ret + } + +conversion_declarator: + | ptr_operator conversion_declarator + { () } + | ptr_operator %prec LOW_PRIORITY_RULE + { () } + +/*(*************************************************************************)*/ +/*(*1 Class and struct definitions *)*/ +/*(*************************************************************************)*/ + +/*(* this can come from a simple_declaration/decl_spec *)*/ +class_specifier: + | class_head TOBrace member_specification_opt TCBrace + { let (kind, nameopt, baseopt) = $1 in + { c_kind = kind; c_name = nameopt; + c_inherit = baseopt; c_members = ($2, $3, $4) } } +/* +(* todo in grammar they allow anon class with base_clause, weird. + * bugfix_c++: in c++ grammar they put identifier but when we do template + * specialization then we can get some template_id. Note that can + * not introduce a class_key_name intermediate cos they get a + * r/r conflict as there is another place with a 'class_key ident' + * in elaborated specifier. So need to duplicate the rule for + * the template_id case. +*)*/ +class_head: + | class_key + { $1, None, None } + | class_key ident base_clause_opt + { let name = None, noQscope, IdIdent $2 in + $1, Some name, $3 } + | class_key nested_name_specifier ident base_clause_opt + { let name = None, $2, IdIdent $3 in + $1, Some name, $4 } + +/*(* was called struct_union before *)*/ +class_key: + | Tstruct { Struct, $1 } + | Tunion { Union, $1 } + /*(*c++ext: *)*/ + | Tclass { Class, $1 } + +/*(*----------------------------*)*/ +/*(*2 c++ext: inheritance rules *)*/ +/*(*----------------------------*)*/ +base_clause: + | TCol base_specifier_list { $1, $2 } + +/*(* base-specifier: + * ::opt nested-name-specifieropt class-name + * virtual access-specifieropt ::opt nested-name-specifieropt class-name + * access-specifier virtualopt ::opt nested-name-specifieropt class-name + * specialisation + *)*/ +base_specifier: + | class_name + { { i_name = $1; i_virtual = None; i_access = None } } + | access_specifier class_name + { { i_name = $2; i_virtual = None; i_access = Some $1 } } + | Tvirtual access_specifier class_name + { { i_name = $3; i_virtual = Some $1; i_access = Some $2 } } + +/*(* TODO? specialisation | ident { $1 }, do heuristic so can remove rule2 *)*/ +class_name: + | type_cplusplus_id { $1 } + | TIdent { None, noQscope, IdIdent $1 } + +/*(*----------------------------*)*/ +/*(*2 c++ext: members *)*/ +/*(*----------------------------*)*/ + +/*(* todo? add cpp_directive possibility here too *)*/ +member_specification: + | member_declaration member_specification_opt + { ClassElem $1::$2 } + | access_specifier TCol member_specification_opt + { ClassElem (Access ($1, $2))::$3 } + +access_specifier: + | Tpublic { Public, $1 } + | Tprivate { Private, $1 } + | Tprotected { Protected, $1 } + + +/*(* in c++ grammar there is a ;opt after function_definition but + * there is a conflict as it can also be an EmptyField *)*/ +member_declaration: + | field_declaration { fixFieldOrMethodDecl $1 } + | function_definition { MemberFunc (FunctionOrMethod $1) } + | qualified_id TPtVirg + { let name = (None, fst $1, snd $1) in + QualifiedIdInClass (name, $2) + } + | using_declaration { UsingDeclInClass $1 } + | template_declaration { TemplateDeclInClass $1 } + + /*(* not in c++ grammar as merged with function_definition, but I can't *)*/ + | ctor_dtor_member { $1 } + + /*(* cppext: as some macro sometimes have a trailing ';' we must allow + * them here. Generates conflicts if keep the opt_ptvirg mentionned + * before. + * c++ext: in c++ grammar they put a double optional but I prefer + * to force the presence of a decl_spec. I don't know what means + * 'x;' in a structure, maybe default to int but not practical for my way of + * parsing + *)*/ + | TPtVirg { EmptyField $1 } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 field declaration *)*/ +/*(*-----------------------------------------------------------------------*)*/ +field_declaration: + | decl_spec TPtVirg + { (* gccext: allow empty elements if it is a structdef or enumdef *) + let (t_ret, sto, _inline) = type_and_storage_from_decl $1 in + let onedecl = { v_namei = None; v_type = t_ret; v_storage = sto } in + ([(FieldDecl onedecl),noii], $2) + } + | decl_spec member_declarator_list TPtVirg + { let (t_ret, sto, _inline) = type_and_storage_from_decl $1 in + ($2 +> (List.map (fun (f, iivirg) -> f t_ret sto, iivirg)), $3) + } + +/*(* was called struct_declarator before *)*/ +member_declarator: + | declarator + { let (name, partialt) = $1 in (fun t_ret sto -> + FieldDecl { + v_namei = Some (name, None); + v_type = partialt t_ret; v_storage = sto; }) + } + /*(* can also be an abstract when it's =0 on a function type *)*/ + | declarator TEq const_expr + { let (name, partialt) = $1 in (fun t_ret sto -> + FieldDecl { + v_namei = Some (name, Some (EqInit ($2, InitExpr $3))); + v_type = partialt t_ret; v_storage = sto; + }) + } + + /*(* normally just ident, but ambiguity so solve by inspetcing declarator *)*/ + | declarator TCol const_expr + { let (name, _partialt) = fixNameForParam $1 in (fun t_ret _stoTODO -> + BitField (Some name, $2, t_ret, $3)) + } + | TCol const_expr + { (fun t_ret _stoTODO -> BitField (None, $1, t_ret, $2)) } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 c++ext: constructor special case *)*/ +/*(*-----------------------------------------------------------------------*)*/ + +/*(* special case for ctor/dtor because they don't have a return type. + * TODOAST on the ctor_spec and chain of calls + *)*/ +ctor_dtor_member: + | ctor_spec TIdent_Constructor TOPar parameter_type_list_opt TCPar + ctor_mem_initializer_list_opt + compound + { MemberFunc (Constructor (mk_constructor $2 ($3, $4, $5) $7)) } + + | ctor_spec TIdent_Constructor TOPar parameter_type_list_opt TCPar TPtVirg + { MemberDecl (ConstructorDecl ($2, ($3, opt_to_list_params $4, $5), $6)) } + + | dtor_spec TTilde ident TOPar void_opt TCPar exn_spec_opt compound + { MemberFunc (Destructor (mk_destructor $2 $3 ($4, $5, $6) $7 $8)) } + | dtor_spec TTilde ident TOPar void_opt TCPar exn_spec_opt TPtVirg + { MemberDecl (DestructorDecl ($2, $3, ($4, $5, $6), $7, $8)) } + + +ctor_spec: + | Texplicit { } + | Tinline { } + | /*(*empty*)*/ { } + +dtor_spec: + | Tvirtual { } + | Tinline { } + | /*(*empty*)*/ { } + +ctor_mem_initializer_list_opt: + | TCol mem_initializer_list { () } + | /*(* empty *)*/ { () } + +mem_initializer: + | mem_initializer_id TOPar argument_list_opt TCPar { () } + +/*(* factorize with declarator_id ? specialisation *)*/ +mem_initializer_id: +/* specialsiation | TIdent { () } */ + | primary_cplusplus_id { () } + +/*(*************************************************************************)*/ +/*(*1 Enum definition *)*/ +/*(*************************************************************************)*/ + +enum_specifier: + | Tenum TOBrace enumerator_list gcc_comma_opt TCBrace + { EnumDef ($1, None, ($2, $3, $5)) (*$4*) } + | Tenum ident TOBrace enumerator_list gcc_comma_opt TCBrace + { EnumDef ($1, Some $2, ($3, $4, $6)) (*$5*) } + +enumerator: + | ident { { e_name = $1; e_val = None; } } + | ident TEq const_expr { { e_name = $1; e_val = Some ($2, $3); } } + +/*(*************************************************************************)*/ +/*(*1 Simple declaration, initializers *)*/ +/*(*************************************************************************)*/ + +simple_declaration: + | decl_spec TPtVirg + { let (t_ret, sto, _inline) = type_and_storage_from_decl $1 in + DeclList ([{v_namei = None; v_type = t_ret; v_storage = sto},noii],$2) + } + | decl_spec init_declarator_list TPtVirg + { let (t_ret, sto, _inline) = type_and_storage_from_decl $1 in + DeclList ( + ($2 +> List.map (fun (((name, f), iniopt), iivirg) -> + (* old: if fst (unwrap storage)=StoTypedef then LP.add_typedef s; *) + { v_namei = Some (name, iniopt); + v_type = f t_ret; v_storage = sto + }, + iivirg + )), $3) + } + /*(* cppext: *)*/ + | TIdent_MacroDecl TOPar argument_list TCPar TPtVirg + { MacroDecl ([], $1, ($2, $3, $4), $5) } + | Tstatic TIdent_MacroDecl TOPar argument_list TCPar TPtVirg + { MacroDecl ([$1], $2, ($3, $4, $5), $6) } + | Tstatic Tconst_MacroDeclConst + TIdent_MacroDecl TOPar argument_list TCPar TPtVirg + { MacroDecl ([$1;$2], $3, ($4, $5, $6), $7) } + +/*(*-----------------------------------------------------------------------*)*/ +/* +(* In c++ grammar they put 'explicit' in function_spec, 'typedef' and 'friend' + * in decl_spec. But it's just estethic as no other rules directly + * mention function_spec or storage_spec. They just want to say that + * 'virtual' applies only to functions, but they have no way to check that + * syntaxically. I could keep as before, as in the C grammar. + * For 'explicit' I prefer to put it directly + * with the ctor as I already have a special heuristic for constructor. + * They also don't put the cv_qualif here but instead inline it in + * type_spec. I prefer to keep as before but I take care when + * they speak about type_spec to translate instead in type+qualif_spec + * (which is spec_qualif_list) + * + * todo? can simplify by putting all in _opt ? must have at least one otherwise + * decl_list is ambiguous ? (no cos have ';' between decl) + *)*/ +decl_spec: + | storage_class_spec { {nullDecl with storageD = $1 } } + | type_spec { addTypeD $1 nullDecl } + | cv_qualif { {nullDecl with qualifD = $1 } } + | function_spec { {nullDecl with inlineD = (true, [snd $1]) } (*TODO*) } + | Ttypedef { {nullDecl with storageD = StoTypedef $1 } } + | Tfriend { {nullDecl with inlineD = (true, [$1]) } (*TODO*) } + + | storage_class_spec decl_spec { addStorageD $1 $2 } + | type_spec decl_spec { addTypeD $1 $2 } + | cv_qualif decl_spec { addQualifD $1 $2 } + | function_spec decl_spec { addInlineD (snd $1) $2 (*TODO*) } + | Ttypedef decl_spec { addStorageD (StoTypedef $1) $2 } + | Tfriend decl_spec { addInlineD $1 $2 (*TODO*)} + +function_spec: + /*(*gccext: and c++ext: *)*/ + | Tinline { Inline, $1 } + /*(*c++ext: *)*/ + | Tvirtual { Virtual, $1 } + +storage_class_spec: + | Tstatic { Sto (Static, $1) } + | Textern { Sto (Extern, $1) } + | Tauto { Sto (Auto, $1) } + | Tregister { Sto (Register,$1) } + /*(* c++ext: *)*/ + | Tmutable { Sto (Register,$1) (*TODO*) } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 declarators (right part of type and variable) *)*/ +/*(*-----------------------------------------------------------------------*)*/ +init_declarator: + | declaratori { ($1, None) } + | declaratori TEq initialize { ($1, Some (EqInit ($2, $3))) } + /* + (* c++ext: c++ initializer via call to constructor. Note that this + * is different from TypedefIdent2, here the declaratori is an ident, + * not the constructorname hence the need for a TOPar_CplusplusInit + *)*/ + | declaratori TOPar_CplusplusInit argument_list_opt TCPar + { ($1, Some (ObjInit ($2, $3, $4))) } + +/*(*----------------------------*)*/ +/*(*2 gccext: *)*/ +/*(*----------------------------*)*/ +declaratori: + | declarator { $1 } + /*(* gccext: *)*/ + | declarator gcc_asm_decl { $1 } + +gcc_asm_decl: + | Tasm volatile_opt TOPar asmbody TCPar { } + +/*(*-----------------------------------------------------------------------*)*/ +/*(*2 initializers *)*/ +/*(*-----------------------------------------------------------------------*)*/ +initialize: + | assign_expr + { InitExpr $1 } + | TOBrace initialize_list gcc_comma_opt_struct TCBrace + { InitList ($1, List.rev $2, $4) (*$3*) } + /*(* gccext: *)*/ + | TOBrace TCBrace + { InitList ($1, [], $2) } + +/* +(* opti: This time we use the weird order of non-terminal which requires in + * the "caller" to do a List.rev cos quite critical. With this wierd order it + * allows yacc to use a constant stack space instead of exploding if we would + * do a 'initialize2 Tcomma initialize_list'. + *) +*/ +initialize_list: + | initialize2 { [$1, []] } + | initialize_list TComma initialize2 { ($3, [$2])::$1 } + + +/*(* gccext: condexpr and no assign_expr cos can have ambiguity with comma *)*/ +initialize2: + | cond_expr + { InitExpr $1 } + | TOBrace initialize_list gcc_comma_opt_struct TCBrace + { InitList ($1, List.rev $2, $4) (*$3*) } + | TOBrace TCBrace + { InitList ($1, [], $2) } + + /*(* gccext: labeled elements, a.k.a designators *)*/ + | designator_list TEq initialize2 + { InitDesignators ($1, $2, $3) } + /*(* gccext: old format, in old kernel for instance *)*/ + | ident TCol initialize2 + { InitFieldOld ($1, $2, $3) } + +/*(* kenccext: c++ext:, but conflcit with array designators *)*/ + | TOCro const_expr TCCro initialize2 + { InitIndexOld (($1, $2, $3), $4) } + | TOCro const_expr TCCro TEq initialize2 + { InitDesignators ([DesignatorIndex($1, $2, $3)], $4, $5) } + +/*(* they can be nested, can have a .x.[3].y *)*/ +designator: + | TDot ident + { DesignatorField ($1, $2) } +/* conflict with kenccext + | TOCro const_expr TCCro %prec LOW_PRIORITY_RULE + { DesignatorIndex ($1, $2, $3) } + | TOCro const_expr TEllipsis const_expr TCCro + { DesignatorRange ($1, ($2, $3, $4), $5) } +*/ +/*(*----------------------------*)*/ +/*(*2 workarounds *)*/ +/*(*----------------------------*)*/ +gcc_comma_opt_struct: + | TComma { Some $1 } + | /*(* empty *)*/ { None } + +/*(*************************************************************************)*/ +/*(*1 Block declaration (namespace and asm) *)*/ +/*(*************************************************************************)*/ + +block_declaration: + | simple_declaration { $1 } + + /*(*gccext: *)*/ + | asm_definition { $1 } + /*(*c++ext: *)*/ + | namespace_alias_definition { $1 } + | using_declaration { UsingDecl $1 } + | using_directive { $1 } + + +/*(*----------------------------*)*/ +/*(*2 c++ext: *)*/ +/*(*----------------------------*)*/ + +namespace_alias_definition: + | Tnamespace TIdent TEq tcolcol_opt nested_name_specifier_opt namespace_name + TPtVirg + { let name = $4, $5, IdIdent $6 in NameSpaceAlias ($1, $2, $3, name, $7) } + +using_directive: + | Tusing Tnamespace tcolcol_opt nested_name_specifier_opt namespace_name + TPtVirg + { let name = $3, $4, IdIdent $5 in UsingDirective ($1, $2, name, $6) } + +/*(* conflict on TColCol in 'Tusing TColCol unqualified_id TPtVirg' + * need LALR(2) to see if after tcol have a nested_name_specifier + * or put opt on nested_name_specifier too + *)*/ +using_declaration: + | Tusing typename_opt tcolcol_opt nested_name_specifier unqualified_id TPtVirg + { let name = ($3, $4, $5) in $1, name, $6 (*$2*) } +/*(* TODO: remove once we don't skip qualifier ? *)*/ + | Tusing typename_opt tcolcol_opt unqualified_id TPtVirg + { let name = ($3, [], $4) in $1, name, $5 (*$2*) } + +/*(*----------------------------*)*/ +/*(*2 gccext: c++ext: *)*/ +/*(*----------------------------*)*/ + +/*(* gccext: c++ext: also apparently *)*/ +asm_definition: + | Tasm volatile_opt TOPar asmbody TCPar TPtVirg + { Asm($1, $2, ($3, $4, $5), $6) } + +asmbody: + | string_list colon_asm_list { $1, $2 } + | string_list { $1, [] } /*(* in old kernel *)*/ + +colon_asm: + | TCol colon_option_list { Colon $2, [$1] } + +colon_option: + | TString { ColonMisc, [snd $1] } + | TString TOPar asm_expr TCPar { ColonExpr ($2, $3, $4), [snd $1] } + /*(* cppext: certainly a macro *)*/ + | TOCro TIdent TCCro TString TOPar asm_expr TCPar + { ColonExpr ($5, $6, $7), [$1;snd $2;$3;snd $4] } + | TIdent { ColonMisc, [snd $1] } + | /*(* empty *)*/ { ColonMisc, [] } + +asm_expr: assign_expr { $1 } + +/*(*************************************************************************)*/ +/*(*1 Declaration, in c++ sense *)*/ +/*(*************************************************************************)*/ +/* +(* in grammar they have 'explicit_instantiation' but it is equal to + * to template_declaration and so is ambiguous. + * + * declaration > block_declaration > simple_declaration, hmmm + * could be renamed declaration_or_definition + *)*/ +declaration: + | block_declaration { BlockDecl $1 } + + | function_definition { Func (FunctionOrMethod $1) } + + /*(* not in c++ grammar as merged with function_definition, but I can't *)*/ + | ctor_dtor { $1 } + | template_declaration { let (a,b,c) = $1 in TemplateDecl (a,b,c)} + | explicit_specialization { $1 } + | linkage_specification { $1 } + | namespace_definition { $1 } + + /*(* sometimes the function ends with }; instead of just } *)*/ + | TPtVirg { EmptyDef $1 } + + +/*(*----------------------------*)*/ +/*(*2 cppext: *)*/ +/*(*----------------------------*)*/ + +declaration_list_opt: + | /*(*empty*)*/ { [] } + | declaration_list { $1 } + +declaration_list: + | declaration_seq { [$1] } + | declaration_list declaration_seq { $1 @ [$2] } + +declaration_seq: + | declaration { DeclElem $1 } + /* (* cppext: *)*/ + | cpp_directive + { CppDirectiveDecl $1 } + | cpp_ifdef_directive/*(* stat_or_decl_list ...*)*/ + { IfdefDecl $1 } + +/*(*----------------------------*)*/ +/*(*2 c++ext: *)*/ +/*(*----------------------------*)*/ + +/*(*todo: export_opt, but generates lots of conflicts *)*/ +template_declaration: + | Ttemplate TInf_Template template_parameter_list TSup_Template declaration + { ($1, ($2, $3, $4), $5) } + +explicit_specialization: + | Ttemplate TInf_Template TSup_Template declaration + { TemplateSpecialization ($1, ($2, (), $3), $4) } + +/*(*todo: '| type_paramter' + * ambiguity with parameter_decl cos a type can also be 'class X' + | Tclass ident { raise Todo } + *)*/ +template_parameter: + | parameter_decl { $1 } + + +/*(* c++ext: could also do a extern_string_opt to factorize stuff *)*/ +linkage_specification: + | Textern TString declaration + { ExternC ($1, (snd $2), $3) } + | Textern TString TOBrace declaration_list_opt TCBrace + { ExternCList ($1, (snd $2), ($3, $4, $5)) } + + +namespace_definition: + | named_namespace_definition { $1 } + | unnamed_namespace_definition { $1 } + +/* +(* in c++ grammar they make diff between 'original' and 'extension' namespace + * definition but they require some contextual information to know if + * an identifier was already a namespace. So here I have just a single rule. + *)*/ +named_namespace_definition: + | Tnamespace TIdent TOBrace declaration_list_opt TCBrace + { NameSpace ($1, $2, ($3, $4, $5)) } + +unnamed_namespace_definition: + | Tnamespace TOBrace declaration_list_opt TCBrace + { NameSpaceAnon ($1, ($2, $3, $4)) } + + +/* +(* Special case cos ctor/dtor do not have return type. + * TODO scope ? do a start_constructor ? + *)*/ +ctor_dtor: + | nested_name_specifier TIdent_Constructor TOPar parameter_type_list_opt TCPar + ctor_mem_initializer_list_opt + compound + { DeclTodo } + /*(* new_type_id, could also introduce a Tdestructorname or forbidy the + TypedefIdent2 transfo by putting a guard in the lalr(k) rule by + checking if have a ~ before + *)*/ + | nested_name_specifier TTilde ident TOPar void_opt TCPar compound + { DeclTodo } + +/*(* TODO: remove once we don't skip qualifiers *)*/ + | inline_opt TIdent_Constructor TOPar parameter_type_list_opt TCPar + ctor_mem_initializer_list_opt + compound + { DeclTodo } + | TTilde ident TOPar void_opt TCPar exn_spec_opt compound + { DeclTodo } + +/*(*************************************************************************)*/ +/*(*1 Function definition *)*/ +/*(*************************************************************************)*/ + +function_definition: start_fun compound + { fixFunc ($1, $2) } + +start_fun: decl_spec declarator + { let (t_ret, sto) = type_and_storage_for_funcdef_from_decl $1 in + (fst $2, fixOldCDecl ((snd $2) t_ret), sto) + } + +/*(*************************************************************************)*/ +/*(*1 Cpp directives *)*/ +/*(*************************************************************************)*/ + +/*(* cppext: *)*/ +cpp_directive: + | TInclude + { let (_include_str, filename, tok) = $1 in + (* redo some lexing work :( *) + let inc_kind, path = + match () with + | _ when filename =~ "^\"\\(.*\\)\"$" -> Local, matched1 filename + | _ when filename =~ "^\\<\\(.*\\)\\>$" -> Standard, matched1 filename + | _ -> Weird, filename + in + Include (tok, inc_kind, path) + } + + | TDefine TIdent_Define define_val TCommentNewline_DefineEndOfMacro + { Define ($1, $2, DefineVar, $3) (*$4??*) } + /* + (* The TOPar_Define is introduced to avoid ambiguity with previous rules. + * A TOPar_Define is a TOPar that was just next to the ident (no space). + * See parsing_hacks_define.ml + *)*/ + | TDefine TIdent_Define TOPar_Define param_define_list_opt TCPar + define_val TCommentNewline_DefineEndOfMacro + { Define ($1, $2, (DefineFunc ($3, $4, $5)), $6) (*$7*) } + + | TUndef { Undef $1 } + | TCppDirectiveOther { PragmaAndCo $1 } + +define_val: + /*(* perhaps better to use assign_expr? but in that case need + * do a assign_expr_of_string'in parse_c. + * c++ext: update, now statement include simple declarations + * so maybe can parse $1 and generate the previous DefineDecl + * and DefineFunction? cos nested_func is also now inside statement. + *)*/ + | expr { DefineExpr $1 } + | statement { DefineStmt $1 } + /*(* for statement-like macro with fixed number of arguments *)*/ + | Tdo statement Twhile TOPar expr TCPar + { match $5 with + | (C (Int ("0"))), [tok] -> DefineDoWhileZero ($2, [$1;$3;$4;tok;$6]) + | _ -> raise Parsing.Parse_error + } + /*(* for statement-like macro with varargs *)*/ + | Tif TOPar expr TCPar id_expression + { let name = (None, fst $5, snd $5) in + DefinePrintWrapper ($1, ($2, $3, $4), name) + } + | TOBrace_DefineInit initialize_list TCBrace comma_opt + { DefineInit (InitList ($1, List.rev $2, $3) (*$4*)) } + | /*(* empty *)*/ { DefineEmpty } + + +param_define: + | ident { fst $1, [snd $1] } + + | TDefParamVariadic { fst $1, [snd $1] } + | TEllipsis { "...", [$1] } + /*(* they reuse keywords :( *)*/ + | Tregister { "register", [$1] } + | Tnew { "new", [$1] } + + +cpp_ifdef_directive: + | TIfdef { Ifdef, $1 } + | TIfdefelse { IfdefElse, $1 } + | TIfdefelif { IfdefElseif, $1 } + | TEndif { IfdefEndif, $1 } + + | TIfdefBool { Ifdef, snd $1 } + | TIfdefMisc { Ifdef, snd $1 } + | TIfdefVersion { Ifdef, snd $1 } + +cpp_other: +/*(* cppext: *)*/ + | TIdent TOPar argument_list TCPar TPtVirg + { MacroTop ($1, ($2, $3, $4), Some $5) } + + /*(* TCPar_EOL to fix the end-of-stream bug of ocamlyacc *)*/ + | TIdent TOPar argument_list TCPar_EOL + { MacroTop ($1, ($2, $3, $4), None) } + + /*(* ex: EXPORT_NO_SYMBOLS; *)*/ + | TIdent TPtVirg { MacroVarTop ($1, $2) } + +/*(*************************************************************************)*/ +/*(*1 toplevel *)*/ +/*(*************************************************************************)*/ + +toplevel: + | toplevel_aux { Some $1 } + | EOF { None } + +toplevel_aux: + | declaration { DeclElem $1 } + + | cpp_directive { CppDirectiveDecl $1 } + | cpp_ifdef_directive /*(*external_declaration_list ...*)*/ { IfdefDecl $1 } + | cpp_other { $1 } + + /* + (* when have error recovery, we can end up skipping the + * beginning of the file, and so get trailing unclose } at + * end + *)*/ + | TCBrace { DeclElem (EmptyDef $1) } + +/*(*************************************************************************)*/ +/*(*1 xxx_list, xxx_opt *)*/ +/*(*************************************************************************)*/ + +string_list: + | string_elem { $1 } + | string_list string_elem { $1 @ $2 } + +colon_asm_list: + | colon_asm { [$1] } + | colon_asm_list colon_asm { $1 @ [$2] } + +colon_option_list: + | colon_option { [$1, []] } + | colon_option_list TComma colon_option { $1 @ [$3, [$2]] } + + +argument_list: + | argument { [$1, []] } + | argument_list TComma argument { $1 @ [$3, [$2]] } + + +enumerator_list: + | enumerator { [$1, []] } + | enumerator_list TComma enumerator { $1 @ [$3, [$2]] } + + +init_declarator_list: + | init_declarator { [$1, []] } + | init_declarator_list TComma init_declarator { $1 @ [$3, [$2]] } + +member_declarator_list: + | member_declarator { [$1, []] } + | member_declarator_list TComma member_declarator { $1 @ [$3, [$2]] } + + + + +param_define_list_opt: + | /*(* empty *)*/ { [] } + | param_define { [$1, []] } + | param_define_list_opt TComma param_define { $1 @ [$3, [$2]] } + +designator_list: + | designator { [$1] } + | designator_list designator { $1 @ [$2] } + + +handler_list: + | handler { [$1] } + | handler_list handler { $1 @ [$2] } + + +mem_initializer_list: + | mem_initializer { [$1, []] } + | mem_initializer_list TComma mem_initializer { $1 @ [$3, [$2]] } + +template_argument_list: + | template_argument { [$1, []] } + | template_argument_list TComma template_argument { $1 @ [$3, [$2]] } + +template_parameter_list: + | template_parameter { [$1, []] } + | template_parameter_list TComma template_parameter { $1 @ [$3, [$2]] } + + +base_specifier_list: + | base_specifier { [$1, []] } + | base_specifier_list TComma base_specifier { $1 @ [$3, [$2]] } + +/*(*-----------------------------------------------------------------------*)*/ + +/*(* gccext: which allow a trailing ',' in enum, as in perl *)*/ +gcc_comma_opt: + | TComma { [$1] } + | /*(* empty *)*/ { [] } + +comma_opt: + | TComma { [$1] } + | { [] } + + +assign_expr_opt: + | assign_expr { Some $1 } + | /*(* empty *)*/ { None } + +expr_opt: + | expr { Some $1 } + | /*(* empty *)*/ { None } + + + +argument_list_opt: + | argument_list { $1 } + | /*(*empty*)*/ { [] } + +parameter_type_list_opt: + | parameter_type_list { Some $1 } + | /*(*empty*)*/ { None } + + +member_specification_opt: + | member_specification { $1 } + | /*(*empty*)*/ { [] } + + +nested_name_specifier_opt: + | nested_name_specifier { $1 } + | /*(* empty *)*/ { [] } + +nested_name_specifier_opt2: + | nested_name_specifier2 { $1 } + | /*(* empty *)*/ { [] } + + + +exn_spec_opt: + | exception_specification { Some $1 } + | /*(*empty*)*/ { None } + + +/*(*c++ext: ??? *)*/ +new_placement_opt: + | new_placement { Some $1 } + | /*(*empty*)*/ { None } + +new_initializer_opt: + | new_initializer { Some $1 } + | /*(*empty*)*/ { None } + + + +base_clause_opt: + | base_clause { Some $1 } + | /*(*empty*)*/ { None } + +typename_opt: + | Ttypename { [$1] } + | /*(*empty*)*/ { [] } + +template_opt: + | Ttemplate { [$1] } + | /*(*empty*)*/ { [] } + +/* +export_opt: + | Texport { Some $1 } + | (*empty*) { None } + +ptvirg_opt: + | TPtVirg { [$1] } + | { [] } +*/ + +void_opt: + | Tvoid { Some $1 } + | /*(*empty*)*/ { None } + +inline_opt: + | Tinline { Some $1 } + | /*(*empty*)*/ { None } + +volatile_opt: + | Tvolatile { Some $1 } + | /*(*empty*)*/ { None } + +tcolcol_opt: + | TColCol { Some $1 } + | /*(* empty *)*/ { None } diff --git a/lang_cpp/parsing/parser_cpp_mly_helper.ml b/lang_cpp/parsing/parser_cpp_mly_helper.ml new file mode 100644 index 0000000..6b398bc --- /dev/null +++ b/lang_cpp/parsing/parser_cpp_mly_helper.ml @@ -0,0 +1,344 @@ +open Common + +open Ast_cpp + +module Ast = Ast_cpp +module Flag = Flag_parsing_cpp + +(*****************************************************************************) +(* Wrappers *) +(*****************************************************************************) +let pr2, pr2_once = Common2.mk_pr2_wrappers Flag.verbose_parsing + +let warning s v = + if !Flag.verbose_parsing + then Common2.warning ("PARSING: " ^ s) v + else v + +exception Semantic of string * Ast_cpp.tok + +(*****************************************************************************) +(* Parse helpers functions *) +(*****************************************************************************) + +(*-------------------------------------------------------------------------- *) +(* Type related *) +(*-------------------------------------------------------------------------- *) + +type shortLong = Short | Long | LongLong + +(* note: have a full_info: parse_info list; to remember ordering + * between storage, qualifier, type? well this info is already in + * the Ast_c.info, just have to sort them to get good order + *) +type decl = { + storageD: storage; + typeD: (sign option * shortLong option * typeCbis option) wrap; + qualifD: typeQualifier; + inlineD: bool wrap; +} + +let nullDecl = { + storageD = NoSto; + typeD = (None, None, None), noii; + qualifD = Ast.nQ; + inlineD = false, noii; +} + +let addStorageD x decl = + match decl with + | {storageD = NoSto; _} -> { decl with storageD = x } + | {storageD = (StoTypedef ii | Sto (_, ii)) as y; _} -> + if x = y + then decl +> warning "duplicate storage classes" + else raise (Semantic ("multiple storage classes", ii)) + +let addInlineD ii decl = + match decl with + | {inlineD = (false,[]); _} -> { decl with inlineD=(true,[ii])} + | {inlineD = (true, _ii2); _} -> decl +> warning "duplicate inline" + | _ -> raise Impossible + + +let addTypeD ty decl = + match ty, decl with + | (Left3 Signed,_ii), {typeD = ((Some Signed, _b,_c),_ii2); _} -> + decl +> warning "duplicate 'signed'" + | (Left3 UnSigned,_ii), {typeD = ((Some UnSigned,_b,_c),_ii2); _} -> + decl +> warning "duplicate 'unsigned'" + | (Left3 _,ii), {typeD = ((Some _,_b,_c),_ii2); _} -> + raise (Semantic ("both signed and unsigned specified", List.hd ii)) + | (Left3 x,ii), {typeD = ((None,b,c),ii2); _} -> + { decl with typeD = (Some x,b,c),ii @ ii2} + | (Middle3 Short,_ii), {typeD = ((_a,Some Short,_c),_ii2); _} -> + decl +> warning "duplicate 'short'" + + + (* gccext: long long allowed *) + | (Middle3 Long,ii), {typeD = ((a,Some Long,c),ii2); _}-> + { decl with typeD = (a, Some LongLong, c),ii@ii2 } + | (Middle3 Long,_ii), {typeD = ((_a,Some LongLong,_c),_ii2); _} -> + decl +> warning "triplicate 'long'" + + | (Middle3 _,ii), {typeD = ((_a,Some _,_c),_ii2); _} -> + raise (Semantic ("both long and short specified", List.hd ii)) + | (Middle3 x,ii), {typeD = ((a,None,c),ii2); _} -> + { decl with typeD = (a, Some x,c),ii@ii2} + + | (Right3 _t,ii), {typeD = ((_a,_b,Some _),_ii2); _} -> + raise (Semantic ("two or more data types", List.hd ii)) + | (Right3 t,ii), {typeD = ((a,b,None),ii2); _} -> + { decl with typeD = (a,b, Some t),ii@ii2} + + +let addQualif tq1 tq2 = + match tq1, tq2 with + | {const=Some _; _}, {const=Some _; _} -> + tq2 +> warning "duplicate 'const'" + | {volatile=Some _; _}, {volatile=Some _; _} -> + tq2 +> warning "duplicate 'volatile'" + | {const=Some x; _}, _ -> + { tq2 with const = Some x} + | {volatile=Some x; _}, _ -> + { tq2 with volatile = Some x} + | _ -> Common2.internal_error "there is no noconst or novolatile keyword" + +let addQualifD qu qu2 = + { qu2 with qualifD = addQualif qu qu2.qualifD } + + +(*-------------------------------------------------------------------------- *) +(* Declaration/Function related *) +(*-------------------------------------------------------------------------- *) + +(* stdC: type section, basic integer types (and ritchie) + * To understand the code, just look at the result (right part of the PM) + * and go back. + *) +let type_and_storage_from_decl + {storageD = st; + qualifD = qu; + typeD = (ty,iit); + inlineD = (inline,iinl); + } = + (qu, + (match ty with + | (None, None, None) -> + (* mine (originally default to int, but this looks like bad style) *) + let decl = + { v_namei = None; v_type = qu, (BaseType Void, iit); v_storage = st } in + raise (Semantic ("no type (could default to 'int')", + List.hd (Lib_parsing_cpp.ii_of_any (OneDecl decl)))) + | (None, None, Some t) -> (t, iit) + + | (Some sign, None, (None| Some (BaseType (IntType (Si (_,CInt)))))) -> + BaseType(IntType (Si (sign, CInt))), iit + | ((None|Some Signed),Some x,(None|Some(BaseType(IntType (Si (_,CInt)))))) -> + BaseType(IntType (Si (Signed, [Short,CShort; Long, CLong; LongLong, CLongLong] +> List.assoc x))), iit + | (Some UnSigned, Some x, (None| Some (BaseType (IntType (Si (_,CInt))))))-> + BaseType(IntType (Si (UnSigned, [Short,CShort; Long, CLong; LongLong, CLongLong] +> List.assoc x))), iit + | (Some sign, None, (Some (BaseType (IntType CChar)))) -> BaseType(IntType (Si (sign, CChar2))), iit + | (None, Some Long,(Some(BaseType(FloatType CDouble)))) -> BaseType (FloatType (CLongDouble)), iit + + | (Some _,_, Some _) -> + raise (Semantic("signed, unsigned valid only for char and int", List.hd iit)) + | (_,Some _,(Some(BaseType(FloatType (CFloat|CLongDouble))))) -> + raise (Semantic ("long or short specified with floatint type", List.hd iit)) + | (_,Some Short,(Some(BaseType(FloatType CDouble)))) -> + raise (Semantic ("the only valid combination is long double", List.hd iit)) + + | (_, Some _, Some _) -> + (* mine *) + raise (Semantic ("long, short valid only for int or float", List.hd iit)) + + (* if do short uint i, then gcc say parse error, strange ? it is + * not a parse error, it is just that we dont allow with typedef + * either short/long or signed/unsigned. In fact, with + * parse_typedef_fix2 (with et() and dt()) now I say too parse + * error so this code is executed only when do short struct + * {....} and never with a typedef cos now we parse short uint i + * as short ident ident => parse error (cos after first short i + * pass in dt() mode) *) + )), st, (inline, iinl) + + +let type_and_register_from_decl decl = + let {storageD = st; _} = decl in + let (t,_storage, _inline) = type_and_storage_from_decl decl in + match st with + | NoSto -> t, None + | Sto (Register, ii) -> t, Some ii + | StoTypedef ii | Sto (_, ii) -> + raise (Semantic ("storage class specified for parameter of function", ii)) + +let fixNameForParam (name, ftyp) = + match name with + | None, [], IdIdent id -> id, ftyp + | _ -> + let ii = Lib_parsing_cpp.ii_of_any (Name name) +> List.hd in + raise (Semantic ("parameter have qualifier", ii)) + +let type_and_storage_for_funcdef_from_decl decl = + let (returnType, storage, _inline) = type_and_storage_from_decl decl in + (match storage with + | StoTypedef tok -> + raise (Semantic ("function definition declared 'typedef'", tok)) + | _x -> (returnType, storage) + ) + +(* + * this function is used for func definitions (not declarations). + * In that case we must have a name for the parameter. + * This function ensures that we give only parameterTypeDecl with well + * formed Classic constructor. + * + * todo?: do we accept other declaration in ? + * so I must add them to the compound of the deffunc. I dont + * have to handle typedef pb here cos C forbid to do VF f { ... } + * with VF a typedef of func cos here we dont see the name of the + * argument (in the typedef) + *) +let (fixOldCDecl: fullType -> fullType) = fun ty -> + match snd ty with + | FunctionType ({ft_params=params;_}),_iifunc -> + (* stdC: If the prototype declaration declares a parameter for a + * function that you are defining (it is part of a function + * definition), then you must write a name within the declarator. + * Otherwise, you can omit the name. *) + (match Ast.unparen params with + | [{p_name = None; p_type = ty2;_},_] -> + (match Ast.unwrap_typeC ty2 with + | BaseType Void -> ty + | _ -> + (* less: there is some valid case actually, when use interfaces + * and generic callbacks where specific instances do not + * need the extra parameter (happens a lot in plan9). + * Maybe this check is better done in a scheck for C. + let info = Lib_parsing_cpp.ii_of_any (Type ty2) +> List.hd in + pr2 (spf "SEMANTIC: parameter name omitted (but I continue) at %s" + (Parse_info.string_of_info info) + ); + *) + ty + ) + | params -> + (params +> List.iter (fun (param,_) -> + match param with + | {p_name = None; p_type = _ty2; _} -> + (* see above + let info = Lib_parsing_cpp.ii_of_any (Type ty2) +> List.hd in + (* if majuscule, then certainly macro-parameter *) + pr2 (spf "SEMANTIC: parameter name omitted (but I continue) at %s" + (Parse_info.string_of_info info) + ); + *) + () + | _ -> () + )); + ty + ) + (* todo? can we declare prototype in the decl or structdef, + * ... => length <> but good kan meme + *) + | _ -> + (* gcc says parse error but I dont see why *) + let ii = Lib_parsing_cpp.ii_of_any (Type ty) +> List.hd in + raise (Semantic ("seems this is not a function", ii)) + +(* TODO: this is ugly ... use record! *) +let fixFunc ((name, ty, sto), cp) = + match ty with + | (aQ,(FunctionType ({ft_params=params; _} as ftyp),_iifunc)) -> + (* it must be nullQualif, cos parser construct only this *) + assert (aQ =*= nQ); + + (match Ast.unparen params with + [{p_name= None; p_type = ty2;_}, _] -> + (match Ast.unwrap_typeC ty2 with + | BaseType Void -> () + (* failwith "internal errror: fixOldCDecl not good" *) + | _ -> () + ) + | params -> + params +> List.iter (function + | ({p_name = Some _s;_}, _) -> () + (* failwith "internal errror: fixOldCDecl not good" *) + | _ -> () + ) + ); + { f_name = name; f_type = ftyp; f_storage = sto; f_body = cp; } + | _ -> + let ii = Lib_parsing_cpp.ii_of_any (Type ty) +> List.hd in + raise (Semantic ("function definition without parameters", ii)) + +let fixFieldOrMethodDecl (xs, semicolon) = + match xs with + | [FieldDecl({ + v_namei = Some (name, ini_opt); + v_type = (q, (FunctionType ft, ii_ft)); + v_storage = sto; + }), _noiicomma] -> + (* todo? define another type instead of onedecl? *) + MemberDecl (MethodDecl ({ + v_namei = Some (name, None); + v_type = (q, (FunctionType ft, ii_ft)); + v_storage = sto; + }, + (match ini_opt with + | None -> None + | Some (EqInit(tokeq, InitExpr(C(Int "0"), iizero))) -> + Some (tokeq, List.hd iizero) + | _ -> + raise (Semantic ("can't assign expression to method decl", semicolon)) + ), semicolon + )) + + | _ -> MemberField (xs, semicolon) + +(*-------------------------------------------------------------------------- *) +(* shortcuts *) +(*-------------------------------------------------------------------------- *) +let mk_e e ii = (e, ii) + +let mk_funcall e1 args = + Call (e1, args) + +let mk_constructor id (lp, params, rp) cp = + let params, _hasdots = + match params with + | Some (params, ellipsis) -> + params, ellipsis + | None -> [], None + in + let ftyp = { + ft_ret = nQ, (BaseType Void, noii); + ft_params= (lp, params, rp); + ft_dots = None; + (* TODO *) + ft_const = None; + ft_throw = None; + } + in + { f_name = (None, noQscope, IdIdent id); f_type = ftyp; + f_storage = NoSto; f_body = cp + } + +let mk_destructor tilde id (lp, _voidopt, rp) exnopt cp = + let ftyp = { + ft_ret = nQ, (BaseType Void, noii); + ft_params= (lp, [], rp); + ft_dots = None; + ft_const = None; + ft_throw = exnopt; + } + in + { f_name = (None, noQscope, IdDestructor (tilde, id)); f_type = ftyp; + f_storage = NoSto; f_body = cp; + } + +let opt_to_list_params params = + match params with + | Some (params, _ellipsis) -> + (* todo? raise a warning that should not have ellipsis? *) + params + | None -> [] diff --git a/lang_cpp/parsing/parsing_hacks.ml b/lang_cpp/parsing/parsing_hacks.ml new file mode 100644 index 0000000..e895de4 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks.ml @@ -0,0 +1,277 @@ +(* Yoann Padioleau + * + * Copyright (C) 2011,2014 Facebook + * Copyright (C) 2002-2008 Yoann Padioleau + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module Flag = Flag_parsing_cpp +module TH = Token_helpers_cpp +module TV = Token_views_cpp +module T = Parser_cpp +module PI = Parse_info + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * This module tries to detect some cpp, C, or C++ idioms so that we can + * parse as-is files by adjusting or commenting some tokens. + * + * Sometimes we use some name conventions, sometimes indentation information, + * sometimes we do some kind of lalr(k) by finding patterns. We often try to + * work on a better token representation, like ifdef-paren-ized, brace-ized, + * paren-ized, so that we can pattern-match more easily + * complex idioms (see token_views_cpp.ml). + * We also try to get more contextual information such as whether the + * token is in an initializer because many idioms are different + * depending on the context (see token_views_context.ml). + * + * Examples of cpp idioms: + * - if 0 for commenting stuff (not always code, sometimes any text) + * - ifdef old version + * - ifdef funheader + * - ifdef statements, ifdef expression, ifdef-mid + * - macro toplevel (with or without a trailing ';') + * - macro foreach + * - macro higher order + * - macro declare + * - macro debug + * - macro no ';' + * - macro string, and macro function string taking param and ## + * - macro attribute + * + * Examples of C typedef idioms: + * - x * y + * + * Examples of C++ idioms: + * - x<...> for templates. People rarely do x < y > z to express + * relational expressions, so a < followed later by a > is probably a + * template. + * + * See the TIdent_MacroXxx in parser_cpp.mly and MacroXxx in ast_cpp.ml + * + * We also do other stuff involving cpp like expanding macros, + * and we try to parse define body by finding the end of define virtual + * end-of-line token. But now most of the code is actually in pp_token.ml + * It is related to what is in the yacfe configuration file (e.g. standard.h) + *) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let filter_comment_stuff xs = + xs +> List.filter (fun x -> not (TH.is_comment x.TV.t)) + +(*****************************************************************************) +(* Post processing *) +(*****************************************************************************) + +(* to do at the very very end *) +let insert_virtual_positions l = + let strlen x = String.length (Parse_info.str_of_info x) in + let rec loop prev offset = function + [] -> [] + | x::xs -> + let ii = TH.info_of_tok x in + let inject pi = + TH.visitor_info_of_tok (function ii -> Ast_cpp.rewrap_pinfo pi ii)x in + match ii.Parse_info.token with + Parse_info.OriginTok _pi -> + let prev = Parse_info.token_location_of_info ii in + x::(loop prev (strlen ii) xs) + | Parse_info.ExpandedTok (pi,_, _) -> + inject (Parse_info.ExpandedTok (pi, prev,offset)) :: + (loop prev (offset + (strlen ii)) xs) + | Parse_info.FakeTokStr (s,_) -> + inject (Parse_info.FakeTokStr (s, (Some (prev,offset)))) :: + (loop prev (offset + (strlen ii)) xs) + | Parse_info.Ab -> failwith "abstract not expected" in + let rec skip_fake = function + [] -> [] + | x::xs -> + let ii = TH.info_of_tok x in + match ii.Parse_info.token with + Parse_info.OriginTok _pi -> + let prev = Parse_info.token_location_of_info ii in + x::(loop prev (strlen ii) xs) + | _ -> x::skip_fake xs in + skip_fake l + +(*****************************************************************************) +(* C vs C++ *) +(*****************************************************************************) +let fix_tokens_for_language lang xs = + xs +> List.map (fun tok -> + if lang = Flag_parsing_cpp.C && TH.is_cpp_keyword tok + then + let ii = TH.info_of_tok tok in + T.TIdent (PI.str_of_info ii, ii) + else tok + ) + +(*****************************************************************************) +(* Fix tokens *) +(*****************************************************************************) +(* + * Main entry point for the token reclassifier which generates "fresh" tokens. + * + * The order of the rules is important. For instance if you put the + * action heuristic first, then because of ifdef, can have not closed paren + * and so may believe that higher order macro + * and it will eat too much tokens. So important to do + * first the ifdef heuristic. + * + * Note that the functions below work on a list of token_extended + * or on views on top of a list of token_extended. The token_extended record + * contains mutable fields which explains the (ugly but working) imperative + * style of the code below. + * + * I recompute multiple times 'cleaner' cos the mutable + * can have be changed and so we may have more comments + * in the token original list. + *) + +(* we could factorize with fix_tokens_cpp, but for debugging purpose it + * might be good to have two different functions and do far less in + * fix_tokens_c (even though the extra steps in fix_tokens_cpp should + * have no effect on regular C code). + *) +let fix_tokens_c ~macro_defs tokens = + + let tokens = Parsing_hacks_define.fix_tokens_define tokens in + let tokens = fix_tokens_for_language Flag.C tokens in + + let tokens2 = ref (tokens +> Common2.acc_map TV.mk_token_extended) in + + (* ifdef *) + let cleaner = !tokens2 +> filter_comment_stuff in + + let ifdef_grouped = TV.mk_ifdef cleaner in + Parsing_hacks_pp.find_ifdef_funheaders ifdef_grouped; + Parsing_hacks_pp.find_ifdef_bool ifdef_grouped; + Parsing_hacks_pp.find_ifdef_mid ifdef_grouped; + + (* macro part 1 *) + let cleaner = !tokens2 +> Parsing_hacks_pp.filter_pp_or_comment_stuff in + let paren_grouped = TV.mk_parenthised cleaner in + Pp_token.apply_macro_defs macro_defs paren_grouped; + (* because the before field is used by apply_macro_defs *) + tokens2 := TV.rebuild_tokens_extented !tokens2; + + let cleaner = !tokens2 +> Parsing_hacks_pp.filter_pp_or_comment_stuff in + + let paren_grouped = TV.mk_parenthised cleaner in + Parsing_hacks_pp.find_define_init_brace_paren paren_grouped; + Parsing_hacks_pp.find_string_macro_paren paren_grouped; + Parsing_hacks_pp.find_macro_paren paren_grouped; + let cleaner = !tokens2 +> Parsing_hacks_pp.filter_pp_or_comment_stuff in + + + (* tagging contextual info (InFunc, InStruct, etc) *) + let multi_grouped = TV.mk_multi cleaner in + Token_views_context.set_context_tag_multi multi_grouped; + let xxs = Parsing_hacks_typedef.filter_for_typedef multi_grouped in + Parsing_hacks_typedef.find_typedefs xxs; + + insert_virtual_positions (!tokens2 +> Common2.acc_map (fun x -> x.TV.t)) + + + + +let fix_tokens_cpp ~macro_defs tokens = + let tokens = Parsing_hacks_define.fix_tokens_define tokens in + (* let tokens = fix_tokens_for_language Flag.Cplusplus tokens in *) + + let tokens2 = ref (tokens +> Common2.acc_map TV.mk_token_extended) in + + (* ifdef *) + let cleaner = !tokens2 +> filter_comment_stuff in + + let ifdef_grouped = TV.mk_ifdef cleaner in + Parsing_hacks_pp.find_ifdef_funheaders ifdef_grouped; + Parsing_hacks_pp.find_ifdef_bool ifdef_grouped; + Parsing_hacks_pp.find_ifdef_mid ifdef_grouped; + + (* macro part 1 *) + let cleaner = !tokens2 +> Parsing_hacks_pp.filter_pp_or_comment_stuff in + + (* find '<' '>' template symbols. We need that for the typedef + * heuristics. We actually need that even for the paren view + * which is wrong without it. + * + * todo? expand macro first? some expand to lexical_cast ... + * but need correct parenthized view to expand macros => mutually recursive :( + *) + Parsing_hacks_cpp.find_template_inf_sup cleaner; + + let paren_grouped = TV.mk_parenthised cleaner in + Pp_token.apply_macro_defs macro_defs paren_grouped; + + (* because the before field is used by apply_macro_defs *) + tokens2 := TV.rebuild_tokens_extented !tokens2; + + (* could filter also #define/#include *) + let cleaner = !tokens2 +> filter_comment_stuff in + + (* tagging contextual info (InFunc, InStruct, etc). Better to do + * that after the "ifdef-simplification" phase. + *) + let multi_grouped = TV.mk_multi cleaner in + Token_views_context.set_context_tag_multi multi_grouped; + + (* macro part 2 *) + let cleaner = !tokens2 +> Parsing_hacks_pp.filter_pp_or_comment_stuff in + + let paren_grouped = TV.mk_parenthised cleaner in + let line_paren_grouped = TV.mk_line_parenthised paren_grouped in + Parsing_hacks_pp.find_define_init_brace_paren paren_grouped; + Parsing_hacks_pp.find_string_macro_paren paren_grouped; + Parsing_hacks_pp.find_macro_lineparen line_paren_grouped; + Parsing_hacks_pp.find_macro_paren paren_grouped; + + (* todo: at some point we need to remove that and use + * a better filter_for_typedef that also + * works on the nested template arguments. + *) + Parsing_hacks_cpp.find_template_commentize multi_grouped; + let cleaner = !tokens2 +> Parsing_hacks_pp.filter_pp_or_comment_stuff in + + (* must be done before the qualifier filtering *) + Parsing_hacks_cpp.find_constructor_outside_class cleaner; + + Parsing_hacks_cpp.find_qualifier_commentize cleaner; + let cleaner = !tokens2 +> Parsing_hacks_pp.filter_pp_or_comment_stuff in + + let multi_grouped = TV.mk_multi cleaner in + Token_views_context.set_context_tag_cplus multi_grouped; + + Parsing_hacks_cpp.find_constructor cleaner; + + let xxs = Parsing_hacks_typedef.filter_for_typedef multi_grouped in + Parsing_hacks_typedef.find_typedefs xxs; + + (* must be done after the typedef inference *) + Parsing_hacks_cpp.find_constructed_object_and_more cleaner; + (* the pending of find_qualifier_comentize *) + Parsing_hacks_cpp.reclassify_tokens_before_idents_or_typedefs multi_grouped; + + insert_virtual_positions (!tokens2 +> Common2.acc_map (fun x -> x.TV.t)) + + +let fix_tokens ~macro_defs lang a = + Common.profile_code "C++ parsing.fix_tokens" (fun () -> + match lang with + | Flag_parsing_cpp.C -> fix_tokens_c ~macro_defs a + | Flag_parsing_cpp.Cplusplus -> fix_tokens_cpp ~macro_defs a + ) diff --git a/lang_cpp/parsing/parsing_hacks.mli b/lang_cpp/parsing/parsing_hacks.mli new file mode 100644 index 0000000..1932234 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks.mli @@ -0,0 +1,7 @@ + +(* will among other things interally call pp_token.ml to expand some macros *) +val fix_tokens: + macro_defs:(string, Pp_token.define_body) Hashtbl.t -> + Flag_parsing_cpp.language -> + Parser_cpp.token list -> Parser_cpp.token list + diff --git a/lang_cpp/parsing/parsing_hacks_cpp.ml b/lang_cpp/parsing/parsing_hacks_cpp.ml new file mode 100644 index 0000000..1711b8d --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_cpp.ml @@ -0,0 +1,476 @@ +(* Yoann Padioleau + * + * Copyright (C) 2002-2008 Yoann Padioleau + * Copyright (C) 2011 Facebook + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module Flag = Flag_parsing_cpp +module Ast = Ast_cpp + +module TH = Token_helpers_cpp +module TV = Token_views_cpp +module Parser = Parser_cpp +module PI = Parse_info + +open Parser_cpp +open Token_views_cpp + +open Parsing_hacks_lib + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * This file gathers parsing heuristics related to C++. + * See also Token_views_cpp.set_context_tag and + * Parsing_hacks_typedef.filter_for_typedef that have + * heuristics specific to C++. + * + * TODO: * TIdent_TemplatenameInQualifier + * + *) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let no_space_between i1 i2 = + (PI.line_of_info i1 = PI.line_of_info i2) && + (PI.col_of_info i1 + String.length (PI.str_of_info i1))= PI.col_of_info i2 + +(*****************************************************************************) +(* Template inference *) +(*****************************************************************************) + +let templateLOOKAHEAD = 30 + +(* note: no need to check for TCPar to stop for instance the search, + * this is will be done automatically because we would be inside a + * Parenthised expression. + *) +let rec have_a_tsup_quite_close xs = + match xs with + | [] -> false + | x::xs -> + (match x with + | {t=TSup _} -> true + + (* false positive *) + | {t=tok} when TH.is_static_cast_like tok -> false + + (* ugly: *) + | {t=(TOBrace _ | TPtVirg _ | TCol _ | TAssign _ )} -> + false + + | {t=TInf _} -> + (* probably nested template, still try + * TODO: bug when have i < DEG<...>::foo(...) + * we should recurse! + *) + have_a_tsup_quite_close xs + + (* bugfix: but want allow some binary operator :) like '*' *) + | {t=tok} when TH.is_binary_operator_except_star tok -> false + + | _ -> have_a_tsup_quite_close xs + ) + + +(* precondition: there is a tsup *) +let rec find_tsup_quite_close tok_open xs = + let rec aux acc xs = + match xs with + | [] -> + raise (UnclosedSymbol + (spf "PB: find_tsup_quite_close, no > for < at line %d" + (TH.line_of_tok tok_open.t))) + | x::xs -> + (match x with + | {t=TSup ii} -> + List.rev acc, (x,ii), xs + + | {t=TInf _} -> + (* recurse *) + let (before, (tsuptok,_), after) = find_tsup_quite_close x xs in + (* we don't care about this one, it will be eventually be + * transformed by the caller *) + aux (tsuptok:: (List.rev before) @(x::acc)) after + + | x -> aux (x::acc) xs + ) + in + aux [] xs + + +(* note: some macros in standard.h may expand to static_cast, so perhaps + * better to do template detection after macro expansion ? + * + * C-s for TInf_Template in the grammar and you will see all cases + * should be covered by the patterns below. + *) +let find_template_inf_sup xs = + let rec aux xs = + match xs with + | [] -> () + + (* template<...> *) + | {t=Ttemplate _}::({t=TInf i2} as tok2)::xs -> + change_tok tok2 (TInf_Template i2); + let (before_sup, (toksup, toksupi), rest) = + find_tsup_quite_close tok2 xs in + change_tok toksup (TSup_Template toksupi); + + (* recurse *) + aux before_sup; + aux rest + + (* static_cast<...> *) + | {t=tok1}::({t=TInf i2} as tok2)::xs + when TH.is_static_cast_like tok1 -> + change_tok tok2 (TInf_Template i2); + let (before_sup, (toksup, toksupi), rest) = + find_tsup_quite_close tok2 xs in + change_tok toksup (TSup_Template toksupi); + + (* recurse *) + aux before_sup; + aux rest + + (* + * TODO: have_a_tsup_quite_close does not handle a relational < followed + * by a regular template. + *) + | {t=TIdent (_,i1)}::({t=TInf i2} as tok2)::xs + when + no_space_between i1 i2 && (* safe guard, and good style anyway *) + have_a_tsup_quite_close (Common.take_safe templateLOOKAHEAD xs) + -> + change_tok tok2 (TInf_Template i2); + let (before_sup, (toksup, toksupi), rest) = + find_tsup_quite_close tok2 xs in + change_tok toksup (TSup_Template toksupi); + + (* old: was changing to TIdent_Templatename but now first need + * to do the typedef inference and then can transform the + * TIdent_Typedef into a TIdent_Templatename + *) + + (* recurse *) + aux before_sup; + aux rest + + (* special cases which allow extra space between ident and < + * but I think it would be better for people to fix their code + * | {t=TIdent (s,i1)}::({t=TInf i2} as tok2) + * ::tok3::({t=TSup i4} as tok4)::xs -> + * ... + * + *) + + (* recurse *) + | _::xs -> aux xs + + in + aux xs + +(*****************************************************************************) +(* Main heuristics *) +(*****************************************************************************) + +let reclassify_tokens_before_idents_or_typedefs xs = + let groups = List.rev xs in + + let rec aux xs = + match xs with + | [] -> () + + (* xx::yy where yy is ident (funcall, variable, etc) + * need to do that recursively! if have a::b::c + *) + | Tok{t=TIdent _ | TIdent_ClassnameInQualifier _} + ::Tok{t=TColCol _} + ::Tok({t=TIdent (s2, i2)} as tok2)::xs -> + change_tok tok2 (TIdent_ClassnameInQualifier (s2, i2)); + aux ((Tok tok2)::xs) + + (* xx::t wher et is a type + * TODO need to do that recursively! if have a::b::c + *) + | Tok{t=TIdent_Typedef _}::Tok({t=TColCol icolcol} as tcolcol) + ::Tok({t=TIdent (s2, i2)} as tok2)::xs -> + change_tok tok2 (TIdent_ClassnameInQualifier_BeforeTypedef (s2, i2)); + change_tok tcolcol (TColCol_BeforeTypedef icolcol); + aux xs + + (* xx::t<...> where t is a templatename *) + | Tok{t=TIdent_Templatename _}::Tok({t=TColCol icolcol} as tcolcol) + ::Tok({t=TIdent (s2, i2)} as tok2)::xs -> + change_tok tok2 (TIdent_ClassnameInQualifier_BeforeTypedef (s2, i2)); + change_tok tcolcol (TColCol_BeforeTypedef icolcol); + aux xs + + (* t<...> where t is a typedef *) + | Angle (_, xs_angle, _)::Tok({t=TIdent_Typedef (s1, i1)} as tok1)::xs -> + aux xs_angle; + change_tok tok1 (TIdent_Templatename (s1, i1)); + (* recurse with tok1 too! *) + aux (Tok tok1::xs) + +(* TODO + * TIdent_TemplatenameInQualifier ? + *) + + | x::xs -> + (match x with + | Tok _ -> () + | Braces (_, xs, _) + | Parens (_, xs, _) + | Angle (_, xs, _) + -> aux (List.rev xs) + ); + aux xs + in + aux groups; + () + + +(* quite similar to filter_for_typedef + * TODO: at some point need have to remove this and instead + * have a correct filter_for_typedef that also returns + * nested types in template arguments (and some + * typedef heuristics that work on template_arguments too) + * + * TODO: once you don't use it, remove certain grammar rules (C-s TODO) + *) +let find_template_commentize groups = + (* remove template *) + let rec aux xs = + xs +> List.iter (function + | TV.Braces (_, xs, _) -> + aux xs + | TV.Parens (_, xs, _) -> + aux xs + | TV.Angle (_, _xs, _) as angle -> + (* let's commentize everything *) + [angle] +> TV.iter_token_multi (fun tok -> + change_tok tok + (TComment_Cpp (Token_cpp.CplusplusTemplate, TH.info_of_tok tok.t)) + ) + + | TV.Tok tok -> + (* todo? should also pass the static_cast<...> which normally + * expect some TInf_Template after. Right mow I manage + * that by having some extra rules in the grammar + *) + (match tok.t with + | Ttemplate _ -> + change_tok tok + (TComment_Cpp (Token_cpp.CplusplusTemplate, TH.info_of_tok tok.t)) + | _ -> () + ) + ) + in + aux groups + +(* assumes a view without: + * - template arguments + * + * TODO: once you don't use it, remove certain grammar rules (C-s TODO) + * + * note: passing qualifiers is slightly less important than passing template + * arguments because they are before the name (as opposed to templates + * which are after) and most of our heuristics for typedefs + * look tokens forward, not backward (actually a few now look backward too) + *) +let find_qualifier_commentize xs = + let rec aux xs = + match xs with + | [] -> () + + | ({t=TIdent _} as t1)::({t=TColCol _} as t2)::xs -> + [t1; t2] +> List.iter (fun tok -> + change_tok tok + (TComment_Cpp (Token_cpp.CplusplusQualifier, TH.info_of_tok tok.t)) + ); + aux xs + + (* need also to pass the top :: *) + | ({t=TColCol _} as t2)::xs -> + [t2] +> List.iter (fun tok -> + change_tok tok + (TComment_Cpp (Token_cpp.CplusplusQualifier, TH.info_of_tok tok.t)) + ); + aux xs + + (* recurse *) + | _::xs -> + aux xs + in + aux xs + + +(* assumes a view where: + * - set_context_tag has been called. + * TODO: filter the 'explicit' keyword? filter the TCppDirectiveOther + * have a filter_for_constructor? + *) +let find_constructor xs = + let rec aux xs = + match xs with + | [] -> () + + (* { Foo(... *) + | {t=(TOBrace _ | TCBrace _ | TPtVirg _ | Texplicit _);_} + ::({t=TIdent (s1, i1); where=(TV.InClassStruct s2)::_; _} as tok1) + ::{t=TOPar _}::xs when s1 = s2 -> + change_tok tok1 (TIdent_Constructor(s1, i1)); + aux xs + + (* public: Foo(... could also filter the privacy directives so + * need only one rule + *) + | {t=(Tpublic _ | Tprotected _ | Tprivate _)}::{t=TCol _} + ::({t=TIdent (s1, i1); where=(TV.InClassStruct s2)::_; _} as tok1) + ::{t=TOPar _}::xs when s1 = s2 -> + change_tok tok1 (TIdent_Constructor(s1, i1)); + aux xs + + (* recurse *) + | _::xs -> aux xs + in + aux xs + +(* assumes a view where: + * - template have been filtered but NOT the qualifiers! + *) +let find_constructor_outside_class xs = + let rec aux xs = + match xs with + | [] -> () + + | {t=TIdent (s1, _);_}::{t=TColCol _}::({t=TIdent (s2,i2);_} as tok)::xs + when s1 = s2 -> + change_tok tok (TIdent_Constructor (s2, i2)); + aux (tok::xs) + + + (* recurse *) + | _::xs -> aux xs + in + aux xs + + + +(* assumes have: + * - the typedefs + * - the right context + * + * TODO: filter the TCppDirectiveOther, have a filter_for_constructed? + *) +let find_constructed_object_and_more xs = + let rec aux xs = + match xs with + | [] -> () + + | {t=(Tdelete _| Tnew _);_} + ::({t=TOCro i1} as tok1)::({t=TCCro i2} as tok2)::xs -> + change_tok tok1 (TOCro_new i1); + change_tok tok2 (TCCro_new i2); + aux xs + + (* xx yy(1 ... *) + | {t=TIdent_Typedef _;_}::{t=TIdent _;_}:: + ({t=TOPar (ii);where=InArgument::_;_} as tok1)::xs -> + + change_tok tok1 (TOPar_CplusplusInit ii); + aux xs + + (* int yy(1 ... *) + | {t=tok;_}::{t=TIdent _;_}:: + ({t=TOPar (ii);where=InArgument::_;_} as tok1)::xs + when TH.is_basic_type tok + -> + change_tok tok1 (TOPar_CplusplusInit ii); + aux xs + + (* xx& yy(1 ... *) + | {t=TIdent_Typedef _;_}::{t=TAnd _}::{t=TIdent _;_}:: + ({t=TOPar (ii);where=InArgument::_;_} as tok1)::xs -> + + change_tok tok1 (TOPar_CplusplusInit ii); + aux xs + + (* xx yy(zz) + * The InArgument heuristic can't guess anything when just have + * idents inside the parenthesis. It's probably a constructed + * object though. + * TODO? could be a function declaration, especially when at Toplevel. + * If inside a function, then very probably a constructed object. + *) + | {t=TIdent_Typedef _;_}::{t=TIdent _;_}:: + ({t=TOPar (ii);} as tok1)::{t=TIdent _;_}::{t=TCPar _}::xs -> + + change_tok tok1 (TOPar_CplusplusInit ii); + aux xs + + (* xx yy(zz, ww) *) + | {t=TIdent_Typedef _;_}::{t=TIdent _;_} + ::({t=TOPar (ii);} as tok1) + ::{t=TIdent _;_}::{t=TComma _}::{t=TIdent _;_} + ::{t=TCPar _}::xs -> + + change_tok tok1 (TOPar_CplusplusInit ii); + aux xs + + (* xx yy(&zz) *) + | {t=TIdent_Typedef _;_}::{t=TIdent _;_} + ::({t=TOPar (ii);} as tok1) + ::{t=TAnd _} + ::{t=TIdent _;_} + ::{t=TCPar _}::xs -> + + change_tok tok1 (TOPar_CplusplusInit ii); + aux xs + + (* int(), probably part of operator declaration + * could check that token before is a 'operator' + *) + | ({t=kind})::{t=TOPar _}::{t=TCPar _}::xs + when TH.is_basic_type kind -> + aux xs + + (* int(...) unless it's int( * xxx ) *) + | ({t=_kind})::{t=TOPar _}::{t=TMul _}::xs -> + aux xs + | ({t=kind} as tok1)::{t=TOPar _}::xs + when TH.is_basic_type kind -> + let newone = + match kind with + | Tchar ii -> Tchar_Constr ii + | Tshort ii -> Tshort_Constr ii + | Tint ii -> Tint_Constr ii + | Tdouble ii -> Tdouble_Constr ii + | Tfloat ii -> Tfloat_Constr ii + | Tlong ii -> Tlong_Constr ii + | Tbool ii -> Tbool_Constr ii + | Tunsigned ii -> Tunsigned_Constr ii + | Tsigned ii -> Tsigned_Constr ii + | _ -> raise Impossible + in + change_tok tok1 newone; + aux xs + + (* recurse *) + | _::xs -> aux xs + in + aux xs diff --git a/lang_cpp/parsing/parsing_hacks_cpp.mli b/lang_cpp/parsing/parsing_hacks_cpp.mli new file mode 100644 index 0000000..2e5aba2 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_cpp.mli @@ -0,0 +1,17 @@ + +val find_template_inf_sup: + Token_views_cpp.token_extended list -> unit + +val find_template_commentize: + Token_views_cpp.multi_grouped list -> unit +val find_qualifier_commentize: + Token_views_cpp.token_extended list -> unit + +val find_constructor_outside_class: + Token_views_cpp.token_extended list -> unit +val find_constructor: + Token_views_cpp.token_extended list -> unit +val find_constructed_object_and_more: + Token_views_cpp.token_extended list -> unit +val reclassify_tokens_before_idents_or_typedefs: + Token_views_cpp.multi_grouped list -> unit diff --git a/lang_cpp/parsing/parsing_hacks_define.ml b/lang_cpp/parsing/parsing_hacks_define.ml new file mode 100644 index 0000000..c6a7cfe --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_define.ml @@ -0,0 +1,172 @@ +(* Yoann Padioleau + * + * Copyright (C) 2002-2008 Yoann Padioleau + * Copyright (C) 2011 Facebook + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +open Parser_cpp + +module Ast = Ast_cpp +module Parser = Parser_cpp +module TH = Token_helpers_cpp +module Hack = Parsing_hacks_lib +module PI = Parse_info + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * To parse macro definitions I need to do some tricks + * as some information can be computed only at the lexing level. For instance + * the space after the name of the macro in '#define foo (x)' is meaningful + * but the grammar does not have this information. So define_ident() below + * look at such space and generate a special TOpar_Define token. + * + * In a similar way macro definitions can contain some antislash and newlines + * and the grammar need to know where the macro ends which is + * a line-level and so low token-level information. Hence the + * function define_line'()below and the TCommentNewline_DefineEndOfMacro. + * + * update: TCommentNewline_DefineEndOfMacro is handled in a special way + * at different places, a little bit like EOF, especially for error recovery, + * so this is an important token that should not be retagged! + * + * We also change the kind of TIdent to TIdent_Define to avoid bad interactions + * with other parsing_hack tricks. For instant if keep TIdent then + * the stringication heuristics can believe the TIdent is a string-macro. + * So simpler to change the kind of the TIdent in a macro too. + * + * ugly: maybe a better solution perhaps would be to erase + * TCommentNewline_DefineEndOfMacro from the Ast and list of tokens in parse_c. + * + * note: I do a +1 somewhere, it's for the unparsing to correctly sync. + * + * note: can't replace mark_end_define by simply a fakeInfo(). The reason + * is where is the \n TCommentSpace. Normally there is always a last token + * to synchronize on, either EOF or the token of the next toplevel. + * In the case of the #define we got in list of token + * [TCommentSpace "\n"; TDefEOL] but if TDefEOL is a fakeinfo then we will + * not synchronize on it and so we will not print the "\n". + * A solution would be to put the TDefEOL before the "\n". + * + * todo?: could put a ExpandedTok for that ? + *) + +(*****************************************************************************) +(* Wrappers *) +(*****************************************************************************) +let pr2, _pr2_once = Common2.mk_pr2_wrappers Flag_parsing_cpp.verbose_lexing + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let mark_end_define ii = + let ii' = + { Parse_info. + token = Parse_info.OriginTok { + (Parse_info.token_location_of_info ii) with + Parse_info.str = ""; + Parse_info.charpos = PI.pos_of_info ii + 1 + }; + transfo = Parse_info.NoTransfo; + } + in + (* fresh_tok *) TCommentNewline_DefineEndOfMacro (ii') + +let pos ii = Parse_info.string_of_info ii + +(*****************************************************************************) +(* Parsing hacks for #define *) +(*****************************************************************************) + +(* simple automata: + * state1 --'#define'--> state2 --change_of_line--> state1 + *) + +(* put the TCommentNewline_DefineEndOfMacro at the good place + * and replace \ with TCommentSpace + *) +let rec define_line_1 xs = + match xs with + | [] -> [] + | (TDefine ii as x)::xs -> + let line = PI.line_of_info ii in + x::define_line_2 line ii xs + | TCppEscapedNewline ii::xs -> + pr2 (spf "WEIRD: a \\ outside a #define at %s" (pos ii)); + (* fresh_tok*) TCommentSpace ii::define_line_1 xs + | x::xs -> + x::define_line_1 xs + +and define_line_2 line lastinfo xs = + match xs with + | [] -> + (* should not happened, should meet EOF before *) + pr2 "PB: WEIRD in Parsing_hack_define.define_line_2"; + mark_end_define lastinfo::[] + | x::xs -> + let line' = TH.line_of_tok x in + let info = TH.info_of_tok x in + + (match x with + | EOF ii -> + mark_end_define lastinfo::EOF ii::define_line_1 xs + | TCppEscapedNewline ii -> + if (line' <> line) + then pr2 "PB: WEIRD: not same line number"; + (* fresh_tok*) TCommentSpace ii::define_line_2 (line+1) info xs + | x -> + if line' = line + then x::define_line_2 line info xs + else + mark_end_define lastinfo::define_line_1 (x::xs) + ) + +(* put the TIdent_Define and TOPar_Define *) +let rec define_ident xs = + match xs with + | [] -> [] + | (TDefine ii as x)::xs -> + x:: + (match xs with + | (TCommentSpace _ as x)::TIdent (s,i2)::(* no space *)TOPar (i3)::xs -> + (* if TOPar_Define is just next to the ident (no space), then + * it's a macro-function. We change the token to avoid + * ambiguity between '#define foo(x)' and '#define foo (x)' + *) + x + ::Hack.fresh_tok (TIdent_Define (s,i2)) + ::Hack.fresh_tok (TOPar_Define i3) + ::define_ident xs + + | (TCommentSpace _ as x)::TIdent (s,i2)::xs -> + x + ::Hack.fresh_tok (TIdent_Define (s,i2)) + ::define_ident xs + | _ -> + pr2 (spf "WEIRD #define body, at %s" (pos ii)); + define_ident xs + ) + | x::xs -> + x::define_ident xs + +(*****************************************************************************) +(* Entry point *) +(*****************************************************************************) + +let fix_tokens_define2 xs = + define_ident (define_line_1 xs) + +let fix_tokens_define a = + Common.profile_code "Hack.fix_define" (fun () -> fix_tokens_define2 a) diff --git a/lang_cpp/parsing/parsing_hacks_define.mli b/lang_cpp/parsing/parsing_hacks_define.mli new file mode 100644 index 0000000..731e81d --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_define.mli @@ -0,0 +1,6 @@ + +(* transform TDefine, filter the TCppEscapedNewline, generate TIdentDefine + * and other related fresh tokens. + *) +val fix_tokens_define : + Parser_cpp.token list -> Parser_cpp.token list diff --git a/lang_cpp/parsing/parsing_hacks_lib.ml b/lang_cpp/parsing/parsing_hacks_lib.ml new file mode 100644 index 0000000..daa2da0 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_lib.ml @@ -0,0 +1,287 @@ +(* Yoann Padioleau + * + * Copyright (C) 2002-2008 Yoann Padioleau + * Copyright (C) 2011 Facebook + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module Flag = Flag_parsing_cpp +module Ast = Ast_cpp + +module TH = Token_helpers_cpp +module Parser = Parser_cpp +module PI = Parse_info + +open Parser_cpp +open Token_views_cpp + +(*****************************************************************************) +(* Wrappers *) +(*****************************************************************************) +let pr2, _pr2_once = Common2.mk_pr2_wrappers Flag_parsing_cpp.verbose_parsing + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +(* + * In the following, there are some harcoded names of types or macros + * but they are not used by our heuristics! They are just here to + * enable to detect false positive by printing only the typedef/macros + * that we don't know yet. If we print everything, then we can easily + * get lost with too much verbose tracing information. So those + * functions "filter" some messages. So our heuristics are still good, + * there is no more (or not that much) hardcoded linux stuff. + *) +let msg_gen is_known printer s = + if not (!Flag.filter_msg) + then printer s + else + if not (is_known s) + then printer s + +let pos ii = Parse_info.string_of_info ii + +(*****************************************************************************) +(* Some debugging functions *) +(*****************************************************************************) + +let pr2_pp s = + if !Flag.debug_pp + then Common.pr2 ("PP-" ^ s) + +let pr2_cplusplus s = + if !Flag.debug_cplusplus + then Common.pr2 ("C++-" ^ s) + +let pr2_typedef s = + if !Flag.debug_typedef + then Common.pr2 ("TYPEDEF-" ^ s) + + +let msg_change_tok tok = + match tok with + + (* mostly in parsing_hacks_define.ml *) + + | TIdent_Define (_s, _ii) -> + () + | TOPar_Define (_ii) -> + () + | TCommentNewline_DefineEndOfMacro _ -> + () + + (* mostly in parsing_hacks.ml *) + + | TIdent_Typedef (s, ii) -> + (* todo? also do LP.add_typedef_root s ??? *) + s +> msg_gen (fun s -> + match s with + | "u_char" | "u_short" | "u_int" | "u_long" + | "u8" | "u16" | "u32" | "u64" + | "s8" | "s16" | "s32" | "s64" + | "__u8" | "__u16" | "__u32" | "__u64" + -> true + | "acpi_handle" | "acpi_status" -> true + | "FILE" | "DIR" -> true + | s when s =~ ".*_t$" -> true + | _ -> false + ) + (fun s -> pr2_typedef (spf "promoting %s at %s " s (pos ii))) + + (* mostly in parsing_hacks_pp.ml *) + + (* cppext: *) + + | TComment_Pp (directive, ii) -> + let s = PI.str_of_info ii in + (match directive, s with + | Token_cpp.CppMacro, _ -> + pr2_pp (spf "MACRO: commented at %s" (pos ii)) + + | Token_cpp.CppDirective, _ when s =~ "#define.*" -> + pr2_pp (spf "DEFINE: commented at %s" (pos ii)); + | Token_cpp.CppDirective, _ when s =~ "#include.*" -> + pr2_pp (spf "INCLUDE: commented at %s" (pos ii)); + | Token_cpp.CppDirective, _ when s =~ "#if.*" -> + pr2_pp (spf "IFDEF: commented at %s" (pos ii)); + | Token_cpp.CppDirective, _ when s =~ "#undef.*" -> + pr2_pp (spf "UNDEF: commented at %s" (pos ii)); + | Token_cpp.CppDirective, _ -> + pr2_pp (spf "OTHER: commented directive at %s" (pos ii)); + | _ -> + (* todo? *) + () + ) + + | TOBrace_DefineInit ii -> + pr2_pp (spf "DEFINE: initializer at %s" (pos ii)) + + | TIdent_MacroString ii -> + let s = PI.str_of_info ii in + s +> msg_gen (fun s -> + match s with + | "REVISION" | "UTS_RELEASE" | "SIZE_STR" | "DMA_STR" + -> true + (* s when s =~ ".*STR.*" -> true *) + | _ -> false + ) + (fun s -> pr2_pp (spf "MACRO: string-macro %s at %s " s (pos ii))) + + | TIdent_MacroStmt ii -> + pr2_pp (spf "MACRO: stmt-macro at %s" (pos ii)); + + | TIdent_MacroDecl (s, ii) -> + s +> msg_gen (fun s -> + match s with + | "DECLARE_MUTEX" | "DECLARE_COMPLETION" | "DECLARE_RWSEM" + | "DECLARE_WAITQUEUE" | "DECLARE_WAIT_QUEUE_HEAD" + | "DEFINE_SPINLOCK" | "DEFINE_TIMER" + | "DEVICE_ATTR" | "CLASS_DEVICE_ATTR" | "DRIVER_ATTR" + | "SENSOR_DEVICE_ATTR" + | "LIST_HEAD" + | "DECLARE_WORK" | "DECLARE_TASKLET" + | "PORT_ATTR_RO" | "PORT_PMA_ATTR" + | "DECLARE_BITMAP" + -> true + (* + | s when s =~ "^DECLARE_.*" -> true + | s when s =~ ".*_ATTR$" -> true + | s when s =~ "^DEFINE_.*" -> true + | s when s =~ "NS_DECL.*" -> true + *) + | _ -> false + ) + (fun _s -> pr2_pp (spf "MACRO: macro-declare at %s" (pos ii))) + + | Tconst_MacroDeclConst ii -> + pr2_pp (spf "MACRO: retag const at %s" (pos ii)) + + | TAny_Action ii -> + pr2_pp (spf "ACTION: retag at %s" (pos ii)) + + | TCPar_EOL ii -> + pr2_pp (spf "MISC: retagging ) %s" (pos ii)) + + (* mostly in parsing_hacks_cpp.ml *) + + (* c++ext: *) + | TComment_Cpp (directive, ii) -> + let s = PI.str_of_info ii in + (match directive, s with + | Token_cpp.CplusplusTemplate, _ -> + pr2_cplusplus (spf "COM-TEMPLATE: commented at %s" (pos ii)) + | Token_cpp.CplusplusQualifier, _ -> + pr2_cplusplus (spf "COM-QUALIFIER: commented at %s" (pos ii)) + ) + + | TOPar_CplusplusInit ii -> + pr2_cplusplus (spf "constructor initializer at %s" (pos ii)) + + | TOCro_new ii | TCCro_new ii -> + pr2_cplusplus (spf "new [] at %s" (pos ii)) + + | TInf_Template ii | TSup_Template ii -> + pr2_cplusplus (spf "template <> at %s" (pos ii)) + + | Tchar_Constr ii | Tint_Constr ii | Tfloat_Constr ii | Tdouble_Constr ii + | Tshort_Constr ii | Tlong_Constr ii | Tbool_Constr ii + | Tunsigned_Constr ii | Tsigned_Constr ii + -> + pr2_cplusplus(spf "constructed object builtin at %s" (pos ii)); + | TIdent_TypedefConstr (s, ii) -> + pr2_cplusplus (spf "constructed object %s at %s" s (pos ii)) + + | TIdent_ClassnameInQualifier (s, ii) -> + pr2_cplusplus (spf "CLASSNAME: in qualifier context %s at %s " s (pos ii)) + | TIdent_Constructor (s, ii) -> + pr2_cplusplus (spf "CONSTRUCTOR: found %s at %s " s (pos ii)) + + | TIdent_Templatename (s, ii) -> + pr2_cplusplus (spf "TEMPLATENAME: found %s at %s" s (pos ii)) + + | TColCol_BeforeTypedef ii -> + pr2_typedef (spf "RECLASSIF colcol to colcol2 at %s" (pos ii)) + + | TIdent_ClassnameInQualifier_BeforeTypedef (s, ii) -> + pr2_typedef (spf "RECLASSIF class in qualifier %s at %s" s (pos ii)) + | TIdent_TemplatenameInQualifier_BeforeTypedef (s, ii) -> + pr2_typedef (spf "RECLASSIF template in qualifier %s at %s" s (pos ii)) + + | _ -> + raise Todo + +let msg_context t ctx = + let ctx_str = + match ctx with + | InParameter -> "InParameter" + | InArgument -> "InArgument" + | _ -> raise Impossible + in + pr2_cplusplus (spf "CONTEXT: %s at %s" ctx_str (pos (TH.info_of_tok t))) + + + +let change_tok extended_tok tok = + msg_change_tok tok; + + (* otherwise parse_c will be lost if don't find a EOF token + * why? because paren detection had a pb because of + * some ifdef-exp? + *) + if TH.is_eof extended_tok.t + then pr2 "PB: wierd, I try to tag an EOF token as something else" + else extended_tok.t <- tok + +let fresh_tok tok = + msg_change_tok tok; + tok + +(* normally the caller have first filtered the set of tokens to have + * a clearer "view" to work on + *) +let set_as_comment cppkind x = + assert(not (TH.is_real_comment x.t)); + change_tok x (TComment_Pp (cppkind, TH.info_of_tok x.t)) + +(*****************************************************************************) +(* The regexp and basic view definitions *) +(*****************************************************************************) + +(* +val regexp_macro: Str.regexp +val regexp_annot: Str.regexp +val regexp_declare: Str.regexp +val regexp_foreach: Str.regexp +val regexp_typedef: Str.regexp +*) + +(* opti: better to built then once and for all, especially regexp_foreach *) + +let regexp_macro = Str.regexp + "^[A-Z_][A-Z_0-9]*$" + +(* linuxext: *) +let regexp_declare = Str.regexp + ".*DECLARE.*" + +(* firefoxext: *) +let regexp_ns_decl_like = Str.regexp + ("\\(" ^ + "NS_DECL_\\|NS_DECLARE_\\|NS_IMPL_\\|" ^ + "NS_IMPLEMENT_\\|NS_INTERFACE_\\|NS_FORWARD_\\|NS_HTML_\\|" ^ + "NS_DISPLAY_\\|NS_IMPL_\\|" ^ + "TX_DECL_\\|DOM_CLASSINFO_\\|NS_CLASSINFO_\\|IMPL_INTERNAL_\\|" ^ + "ON_\\|EVT_\\|NS_UCONV_\\|NS_GENERIC_\\|NS_COM_" ^ + "\\).*") + + diff --git a/lang_cpp/parsing/parsing_hacks_lib.mli b/lang_cpp/parsing/parsing_hacks_lib.mli new file mode 100644 index 0000000..95a8679 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_lib.mli @@ -0,0 +1,20 @@ + +val pr2_pp: string -> unit + +val set_as_comment: + Token_cpp.cppcommentkind -> Token_views_cpp.token_extended -> unit + +val msg_context: + Parser_cpp.token -> Token_views_cpp.context -> unit + +val change_tok: + Token_views_cpp.token_extended -> Parser_cpp.token -> unit +val fresh_tok: + Parser_cpp.token -> Parser_cpp.token + + +val regexp_ns_decl_like: Str.regexp +val regexp_macro: Str.regexp +val regexp_declare: Str.regexp + + diff --git a/lang_cpp/parsing/parsing_hacks_pp.ml b/lang_cpp/parsing/parsing_hacks_pp.ml new file mode 100644 index 0000000..6ff2529 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_pp.ml @@ -0,0 +1,755 @@ +(* Yoann Padioleau + * + * Copyright (C) 2002-2008 Yoann Padioleau + * Copyright (C) 2011 Facebook + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module Flag = Flag_parsing_cpp +module Ast = Ast_cpp + +module TH = Token_helpers_cpp +module TV = Token_views_cpp +module Parser = Parser_cpp +module PI = Parse_info + +open Parser_cpp +open Token_views_cpp + +open Parsing_hacks_lib + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * This file gathers parsing heuristics related to the C preprocessor cpp. + *) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let (==~) = Common2.(==~) + +(* the pair is the status of '()' and '{}', ex: (-1,0) + * if too much ')' and good '{}' + * could do for [] too ? + * could do for ',' if encounter ',' at "toplevel", not inside () or {} + * then if have ifdef, then certainly can lead to a problem. + *) +let (count_open_close_stuff_ifdef_clause: ifdef_grouped list -> (int * int)) = + fun xs -> + let cnt_paren, cnt_brace = ref 0, ref 0 in + xs +> iter_token_ifdef (fun x -> + (match x.t with + | x when TH.is_opar x -> incr cnt_paren + | x when TH.is_obrace x -> incr cnt_brace + | x when TH.is_cpar x -> decr cnt_paren + | x when TH.is_obrace x -> decr cnt_brace + | _ -> () + ) + ); + !cnt_paren, !cnt_brace + +(* look if there is a '{' just after the closing ')', and handling the + * possibility to have nested expressions inside nested parenthesis + *) +(* +let is_really_foreach xs = + let rec is_foreach_aux = function + | [] -> false, [] + | TCPar _::TOBrace _::xs -> true, xs + (* the following attempts to handle the cases where there is a + single statement in the body of the loop. undoubtedly more + cases are needed. + todo: premier(statement) - suivant(funcall) + *) + | TCPar _::TIdent _::xs -> true, xs + | TCPar _::Tif _::xs -> true, xs + | TCPar _::Twhile _::xs -> true, xs + | TCPar _::Tfor _::xs -> true, xs + | TCPar _::Tswitch _::xs -> true, xs + + | TCPar _::xs -> false, xs + | TOPar _::xs -> + let (_, xs') = is_foreach_aux xs in + is_foreach_aux xs' + | x::xs -> is_foreach_aux xs + in + is_foreach_aux xs +> fst +*) + +(* TODO: set_ifdef_parenthize_info ?? from parsing_c/ *) + +let filter_pp_or_comment_stuff xs = + let rec aux xs = + match xs with + | [] -> [] + | x::xs -> + (match x.TV.t with + | tok when TH.is_comment tok -> + aux xs + (* don't want drop the define, or if drop, have to drop + * also its body otherwise the line heuristics may be lost + * by not finding the TDefine in column 0 but by finding + * a TDefineIdent in a column > 0 + * + * todo? but define often contain some unbalanced { + *) + | Parser.TDefine _ -> + x::aux xs + | tok when TH.is_pp_instruction tok -> + aux xs + | _ -> + x::aux xs + ) + in + aux xs + +(*****************************************************************************) +(* Ifdef keeping/passing *) +(*****************************************************************************) + +(* #if 0, #if 1, #if LINUX_VERSION handling *) +let rec find_ifdef_bool xs = + xs +> List.iter (function + | NotIfdefLine _ -> () + | Ifdefbool (is_ifdef_positif, xxs, info_ifdef_stmt) -> + + if is_ifdef_positif + then pr2_pp "commenting parts of a #if 1 or #if LINUX_VERSION" + else pr2_pp "commenting a #if 0 or #if LINUX_VERSION or __cplusplus"; + + (match xxs with + | [] -> raise Impossible + | firstclause::xxs -> + info_ifdef_stmt +> List.iter (set_as_comment Token_cpp.CppDirective); + + if is_ifdef_positif + then xxs +> List.iter + (iter_token_ifdef (set_as_comment Token_cpp.CppOther)) + else begin + firstclause +> iter_token_ifdef (set_as_comment Token_cpp.CppOther); + (match List.rev xxs with + (* keep only last *) + | _last::startxs -> + startxs +> List.iter + (iter_token_ifdef (set_as_comment Token_cpp.CppOther)) + | [] -> (* not #else *) () + ); + end + ); + + | Ifdef (xxs, _info_ifdef_stmt) -> xxs +> List.iter find_ifdef_bool + ) + + + +let thresholdIfdefSizeMid = 6 + +(* infer ifdef involving not-closed expressions/statements *) +let rec find_ifdef_mid xs = + xs +> List.iter (function + | NotIfdefLine _ -> () + | Ifdef (xxs, info_ifdef_stmt) -> + (match xxs with + | [] -> raise Impossible + | [_first] -> () + | _first::second::rest -> + (* don't analyse big ifdef *) + if xxs +> List.for_all + (fun xs -> List.length xs <= thresholdIfdefSizeMid) && + (* don't want nested ifdef *) + xxs +> List.for_all (fun xs -> + xs +> List.for_all + (function NotIfdefLine _ -> true | _ -> false) + ) + + then + let counts = xxs +> List.map count_open_close_stuff_ifdef_clause in + let cnt1, cnt2 = List.hd counts in + if cnt1 <> 0 || cnt2 <> 0 + (*???? && counts +> List.for_all (fun x -> x = (cnt1, cnt2)) *) + (* + if counts +> List.exists (fun (cnt1, cnt2) -> + cnt1 <> 0 || cnt2 <> 0 + ) + *) + then begin + pr2_pp "found ifdef-mid-something"; + (* keep only first, treat the rest as comment *) + info_ifdef_stmt +> List.iter (set_as_comment Token_cpp.CppDirective); + (second::rest) +> List.iter + (iter_token_ifdef (set_as_comment Token_cpp.CppOther)); + end + + ); + List.iter find_ifdef_mid xxs + + (* no need complex analysis for ifdefbool *) + | Ifdefbool (_, xxs, _info_ifdef_stmt) -> + List.iter find_ifdef_mid xxs + ) + + +let thresholdFunheaderLimit = 4 + +(* ifdef defining alternate function header, type *) +let rec find_ifdef_funheaders = function + | [] -> () + | NotIfdefLine _::xs -> find_ifdef_funheaders xs + + (* ifdef-funheader if ifdef with 2 lines and a '{' in next line *) + | Ifdef + ([(NotIfdefLine (({col = 0} as _xline1)::_line1))::ifdefblock1; + (NotIfdefLine (({col = 0} as xline2)::line2))::ifdefblock2 + ], info_ifdef_stmt + ) + ::NotIfdefLine (({t=TOBrace _i; col = 0})::_line3) + ::xs + when List.length ifdefblock1 <= thresholdFunheaderLimit && + List.length ifdefblock2 <= thresholdFunheaderLimit + -> + find_ifdef_funheaders xs; + info_ifdef_stmt +> List.iter (set_as_comment Token_cpp.CppDirective); + let all_toks = [xline2] @ line2 in + all_toks +> List.iter (set_as_comment Token_cpp.CppOther) ; + ifdefblock2 +> iter_token_ifdef (set_as_comment Token_cpp.CppOther); + + (* ifdef with nested ifdef *) + | Ifdef + ([[NotIfdefLine (({col = 0} as _xline1)::_line1)]; + [Ifdef + ([[NotIfdefLine (({col = 0} as xline2)::line2)]; + [NotIfdefLine (({col = 0} as xline3)::line3)]; + ], info_ifdef_stmt2 + ) + ] + ], info_ifdef_stmt + ) + ::NotIfdefLine (({t=TOBrace _i; col = 0})::_line4) + ::xs + -> + find_ifdef_funheaders xs; + info_ifdef_stmt +> List.iter (set_as_comment Token_cpp.CppDirective); + info_ifdef_stmt2 +> List.iter (set_as_comment Token_cpp.CppDirective); + let all_toks = [xline2;xline3] @ line2 @ line3 in + all_toks +> List.iter (set_as_comment Token_cpp.CppOther); + + (* ifdef with elseif *) + | Ifdef + ([[NotIfdefLine (({col = 0} as _xline1)::_line1)]; + [NotIfdefLine (({col = 0} as xline2)::line2)]; + [NotIfdefLine (({col = 0} as xline3)::line3)]; + ], info_ifdef_stmt + ) + ::NotIfdefLine (({t=TOBrace _i; col = 0})::_line4) + ::xs + -> + find_ifdef_funheaders xs; + info_ifdef_stmt +> List.iter (set_as_comment Token_cpp.CppDirective); + let all_toks = [xline2;xline3] @ line2 @ line3 in + all_toks +> List.iter (set_as_comment Token_cpp.CppOther) + + + | Ifdef (xxs,_)::xs + | Ifdefbool (_, xxs,_)::xs -> + List.iter find_ifdef_funheaders xxs; + find_ifdef_funheaders xs + + +(* +let adjust_inifdef_include xs = + xs +> List.iter (function + | NotIfdefLine _ -> () + | Ifdef (xxs, info_ifdef_stmt) | Ifdefbool (_, xxs, info_ifdef_stmt) -> + xxs +> List.iter (iter_token_ifdef (fun tokext -> + match tokext.t with + | Parser.TInclude (s1, s2, ii) -> + (* todo: inifdef_ref := true; *) + () + | _ -> () + )); + ) +*) + +(*****************************************************************************) +(* Builtin macros using standard.h or other defs *) +(*****************************************************************************) +(* now in pp_token.ml *) + +(*****************************************************************************) +(* Stringification *) +(*****************************************************************************) + +let rec find_string_macro_paren xs = + match xs with + | [] -> () + | Parenthised(xxs, _)::xs -> + xxs +> List.iter (fun xs -> + if xs +> List.exists + (function PToken({t=TString _}) -> true | _ -> false) && + xs +> List.for_all + (function PToken({t=TString _}) | PToken({t=TIdent _}) -> + true | _ -> false) + then + xs +> List.iter (fun tok -> + match tok with + | PToken({t=TIdent (_s,_)} as id) -> + change_tok id (TIdent_MacroString (TH.info_of_tok id.t)) + | _ -> () + ) + else + find_string_macro_paren xs + ); + find_string_macro_paren xs + | PToken _ ::xs -> + find_string_macro_paren xs + + +(*****************************************************************************) +(* Macros *) +(*****************************************************************************) + +(* don't forget to recurse in each case. + * note that the code below is called after the ifdef phase simplification, + * so if this previous phase is buggy, then it may pass some code that + * could be matched by the following rules but will not. + **) +let rec find_macro_paren xs = + match xs with + | [] -> () + + (* attribute *) + | PToken ({t=Tattribute _} as id) + ::Parenthised (xxs,info_parens) + ::xs + -> + pr2_pp ("MACRO: __attribute detected "); + [Parenthised (xxs, info_parens)] +> + iter_token_paren (set_as_comment Token_cpp.CppAttr); + set_as_comment Token_cpp.CppAttr id; + find_macro_paren xs + + (* stringification + * + * the order of the matching clause is important + * + *) + + (* string macro with params, before case *) + | PToken ({t=TString _})::PToken ({t=TIdent (_s,_)} as id) + ::Parenthised (xxs, info_parens) + ::xs -> + change_tok id (TIdent_MacroString (TH.info_of_tok id.t)); + [Parenthised (xxs, info_parens)] +> + iter_token_paren (set_as_comment Token_cpp.CppMacro); + find_macro_paren xs + + (* after case *) + | PToken ({t=TIdent (_s,_)} as id) + ::Parenthised (xxs, info_parens) + ::PToken ({t=TString _}) + ::xs -> + change_tok id (TIdent_MacroString (TH.info_of_tok id.t)); + [Parenthised (xxs, info_parens)] +> + iter_token_paren (set_as_comment Token_cpp.CppMacro); + find_macro_paren xs + + + (* for the case where the string is not inside a funcall, but + * for instance in an initializer. + *) + + (* string macro variable, before case *) + | PToken ({t=TString ((str,_),_)})::PToken ({t=TIdent (_s,_)} as id) + ::xs -> + + (* c++ext: *) + if str <> "C" then begin + change_tok id (TIdent_MacroString (TH.info_of_tok id.t)); + find_macro_paren xs + end + (* bugfix, forgot to recurse in else case too ... *) + else + find_macro_paren xs + + (* after case *) + | PToken ({t=TIdent (_s,_)} as id)::PToken ({t=TString _}) + ::xs -> + change_tok id (TIdent_MacroString (TH.info_of_tok id.t)); + find_macro_paren xs + + (* TODO: cooperating with standard.h *) + | PToken ({t=TIdent (s,_i1)} as id)::xs + when s = "MACROSTATEMENT" -> + change_tok id (TIdent_MacroStmt(TH.info_of_tok id.t)); + find_macro_paren xs + + + + (* recurse *) + | (PToken _x)::xs -> find_macro_paren xs + | (Parenthised (xxs, _))::xs -> + xxs +> List.iter find_macro_paren; + find_macro_paren xs + + + + + +(* don't forget to recurse in each case *) +let rec find_macro_lineparen xs = + match xs with + | [] -> () + + (* firefoxext: ex: NS_DECL_NSIDOMNODELIST *) + | (Line ([PToken ({t=TIdent (s,_)} as macro);]))::xs + when s ==~ regexp_ns_decl_like -> + set_as_comment Token_cpp.CppMacro macro; + + find_macro_lineparen (xs) + + (* firefoxext: ex: NS_DECL_NSIDOMNODELIST; *) + | (Line ([PToken ({t=TIdent (s,_)} as macro); + PToken ({t=TPtVirg _})]))::xs + when s ==~ regexp_ns_decl_like -> + set_as_comment Token_cpp.CppMacro macro; + + find_macro_lineparen (xs) + + (* firefoxext: ex: NS_IMPL_XXX(a) *) + | (Line ([PToken ({t=TIdent (s,_)} as macro); + Parenthised (xxs,info_parens); + ]))::xs + when s ==~ regexp_ns_decl_like -> + + [Parenthised (xxs, info_parens)] +> + iter_token_paren (set_as_comment Token_cpp.CppMacro); + set_as_comment Token_cpp.CppMacro macro; + + find_macro_lineparen (xs) + + + (* linuxext: ex: static [const] DEVICE_ATTR(); *) + | (Line + ( + [PToken ({t=Tstatic _}); + PToken ({t=TIdent (s,_)} as macro); + Parenthised (_xxs,_); + PToken ({t=TPtVirg _}); + ] + ))::xs + when (s ==~ regexp_macro) -> + let info = TH.info_of_tok macro.t in + change_tok macro (TIdent_MacroDecl (PI.str_of_info info, info)); + + find_macro_lineparen (xs) + + (* the static const case *) + | (Line + ( + [PToken ({t=Tstatic _}); + PToken ({t=Tconst _} as const); + PToken ({t=TIdent (s,_)} as macro); + Parenthised (_xxs,_info_parens); + PToken ({t=TPtVirg _}); + ] + (*as line1*) + + )) + ::xs + when (s ==~ regexp_macro) -> + let info = TH.info_of_tok macro.t in + change_tok macro (TIdent_MacroDecl (PI.str_of_info info, info)); + + (* need retag this const, otherwise ambiguity in grammar + 21: shift/reduce conflict (shift 121, reduce 137) on Tconst + decl2 : Tstatic . TMacroDecl TOPar argument_list TCPar ... + decl2 : Tstatic . Tconst TMacroDecl TOPar argument_list TCPar ... + storage_class_spec : Tstatic . (137) + *) + change_tok const (Tconst_MacroDeclConst (TH.info_of_tok const.t)); + + find_macro_lineparen (xs) + + + (* same but without trailing ';' + * + * I do not put the final ';' because it can be on a multiline and + * because of the way mk_line is coded, we will not have access to + * this ';' on the next line, even if next to the ')' *) + | (Line + ([PToken ({t=Tstatic _}); + PToken ({t=TIdent (s,_)} as macro); + Parenthised (_xxs,_); + ] + ))::xs + when s ==~ regexp_macro -> + + let info = TH.info_of_tok macro.t in + change_tok macro (TIdent_MacroDecl (PI.str_of_info info, info)); + + find_macro_lineparen (xs) + + + + + (* on multiple lines *) + | (Line + ( + (PToken ({t=Tstatic _})::[] + ))) + ::(Line + ( + [PToken ({t=TIdent (s,_)} as macro); + Parenthised (_,_); + PToken ({t=TPtVirg _}); + ] + ) + )::xs + when (s ==~ regexp_macro) -> + let info = TH.info_of_tok macro.t in + change_tok macro (TIdent_MacroDecl (PI.str_of_info info, info)); + + find_macro_lineparen xs + + + (* linuxext: ex: DECLARE_BITMAP(); + * + * Here I use regexp_declare and not regexp_macro because + * Sometimes it can be a FunCallMacro such as DEBUG(foo()); + * Here we don't have the preceding 'static' so only way to + * not have positive is to restrict to .*DECLARE.* macros. + * + * but there is a grammar rule for that, so don't need this case anymore + * unless the parameter of the DECLARE_xxx are wierd and can not be mapped + * on a argument_list + *) + + | (Line + ([PToken ({t=TIdent (s,_)} as macro); + Parenthised (_,_); + PToken ({t=TPtVirg _}); + ] + ))::xs + when (s ==~ regexp_declare) -> + + let info = TH.info_of_tok macro.t in + change_tok macro (TIdent_MacroDecl (PI.str_of_info info, info)); + + find_macro_lineparen xs + + (* toplevel macros. + * module_init(xxx) + * + * Could also transform the TIdent in a TMacroTop but can have false + * positive, so easier to just change the TCPar and so just solve + * the end-of-stream pb of ocamlyacc + *) + | (Line + ([PToken ({t=TIdent (_s,_ii); col = col1; where = ctx} as _macro); + Parenthised (_,info_parens); + ] as _line1 + )) + ::xs when col1 = 0 + -> + let condition = + (* to reduce number of false positive *) + (match xs with + | (Line (PToken ({col = col2 } as other)::_restline2))::_ -> + TH.is_eof other.t || (col2 = 0 && + (match other.t with + | TOBrace _ -> false (* otherwise would match funcdecl *) + | TCBrace _ when List.hd ctx <> InFunction -> false + | TPtVirg _ + | TCol _ + -> false + | tok when TH.is_binary_operator tok -> false + + | _ -> true + ) + ) + | _ -> false + ) + in + if condition + then begin + (* just to avoid the end-of-stream pb of ocamlyacc *) + let tcpar = Common2.list_last info_parens in + change_tok tcpar (TCPar_EOL (TH.info_of_tok tcpar.t)); + (*macro.t <- TMacroTop (s, TH.info_of_tok macro.t);*) + end; + find_macro_lineparen xs + + + + (* macro with parameters + * ex: DEBUG() + * return x; + *) + | (Line + ([PToken ({t=TIdent (_s,_ii); col = col1; where = ctx} as macro); + Parenthised (xxs,info_parens); + ] as _line1 + )) + ::(Line + (PToken ({col = col2 } as other)::_restline2 + ) as line2) + ::xs + (* when s ==~ regexp_macro *) + -> + let condition = + (col1 = col2 && + (match other.t with + | TOBrace _ -> false (* otherwise would match funcdecl *) + | TCBrace _ when List.hd ctx <> InFunction -> false + | TPtVirg _ + | TCol _ + -> false + | tok when TH.is_binary_operator tok -> false + + | _ -> true + ) + ) + || + (col2 <= col1 && + (match other.t with + | TCBrace _ when List.hd ctx = InFunction -> true + | Treturn _ -> true + | Tif _ -> true + | Telse _ -> true + + | _ -> false + ) + ) + + in + + if condition + then + if col1 = 0 then () + else begin + change_tok macro (TIdent_MacroStmt (TH.info_of_tok macro.t)); + [Parenthised (xxs, info_parens)] +> + iter_token_paren (set_as_comment Token_cpp.CppMacro); + end; + + find_macro_lineparen (line2::xs) + + (* linuxext:? single macro + * ex: LOCK + * foo(); + * UNLOCK + *) + | (Line + ([PToken ({t=TIdent (_s,_ii); col = col1; where = ctx} as macro); + ] as _line1 + )) + ::(Line + (PToken ({col = col2 } as other)::_restline2 + ) as line2) + ::xs -> + (* when s ==~ regexp_macro *) + + let condition = + (col1 = col2 && + col1 <> 0 && (* otherwise can match typedef of fundecl*) + (match other.t with + | TPtVirg _ -> false + | TOr _ -> false + | TCBrace _ when List.hd ctx <> InFunction -> false + | tok when TH.is_binary_operator tok -> false + + | _ -> true + )) || + (col2 <= col1 && + (match other.t with + | TCBrace _ when List.hd ctx = InFunction -> true + | Treturn _ -> true + | Tif _ -> true + | Telse _ -> true + | _ -> false + )) + in + + if condition + then change_tok macro (TIdent_MacroStmt (TH.info_of_tok macro.t)); + + find_macro_lineparen (line2::xs) + + | _x::xs -> + find_macro_lineparen xs + + +(*****************************************************************************) +(* #Define tobrace init *) +(*****************************************************************************) + +let is_init tok2 tok3 = + match tok2.t, tok3.t with + | TInt _, TComma _ -> true + | TString _, TComma _ -> true + | TIdent _, TComma _ -> true + | _ -> false + +let find_define_init_brace_paren xs = + let rec aux xs = + match xs with + | [] -> () + + (* mainly for firefox *) + | (PToken {t=TDefine _}) + ::(PToken {t=TIdent_Define (_s,_)}) + ::(PToken ({t=TOBrace i1} as tokbrace)) + ::(PToken tok2) + ::(PToken tok3) + ::xs -> + if is_init tok2 tok3 + then change_tok tokbrace (TOBrace_DefineInit i1); + aux xs + + (* mainly for linux, especially in sound/ *) + | (PToken {t=TDefine _}) + ::(PToken {t=TIdent_Define (s,_); col=c}) + ::(Parenthised(_, {col=c2; _}::_)) + ::(PToken ({t=TOBrace i1} as tokbrace)) + ::(PToken tok2) + ::(PToken tok3) + ::xs when c2 = c + String.length s -> + if is_init tok2 tok3 + then change_tok tokbrace (TOBrace_DefineInit i1); + + aux xs + + (* ugly: for plan9, too general? *) + | (PToken {t=TDefine _}) + ::(PToken {t=TIdent_Define (_s,_)}) + ::(Parenthised(_xxx, _)) + ::(PToken ({t=TOBrace i1} as tokbrace)) + (* can be more complex expression than just an int, like (b)&... *) + ::(Parenthised(_, _)) + ::(PToken {t=(TAnd _|TOr _);_}) + ::xs -> + change_tok tokbrace (TOBrace_DefineInit i1); + aux xs + + (* recurse *) + | (PToken _)::xs -> aux xs + | (Parenthised (_, _))::xs -> + (* not need for tobrace init: + * xxs +> List.iter aux; + *) + aux xs + in + aux xs + diff --git a/lang_cpp/parsing/parsing_hacks_pp.mli b/lang_cpp/parsing/parsing_hacks_pp.mli new file mode 100644 index 0000000..99af9f2 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_pp.mli @@ -0,0 +1,20 @@ + +val find_ifdef_funheaders: + Token_views_cpp.ifdef_grouped list -> unit +val find_ifdef_bool: + Token_views_cpp.ifdef_grouped list -> unit +val find_ifdef_mid: + Token_views_cpp.ifdef_grouped list -> unit + + +val find_define_init_brace_paren: + Token_views_cpp.paren_grouped list -> unit +val find_string_macro_paren: + Token_views_cpp.paren_grouped list -> unit +val find_macro_lineparen: +Token_views_cpp.paren_grouped Token_views_cpp.line_grouped list -> unit +val find_macro_paren: + Token_views_cpp.paren_grouped list -> unit + +val filter_pp_or_comment_stuff: + Token_views_cpp.token_extended list -> Token_views_cpp.token_extended list diff --git a/lang_cpp/parsing/parsing_hacks_typedef.ml b/lang_cpp/parsing/parsing_hacks_typedef.ml new file mode 100644 index 0000000..7c90499 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_typedef.ml @@ -0,0 +1,375 @@ +(* Yoann Padioleau + * + * Copyright (C) 2011,2014 Facebook + * Copyright (C) 2002-2008 Yoann Padioleau + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module TV = Token_views_cpp +module TH = Token_helpers_cpp +module Ast = Ast_cpp + +open Parser_cpp +open Token_views_cpp +open Parsing_hacks_lib + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * This file gathers parsing heuristics related to the typedefs. + * C does not have a context-free grammar; C requires the parser to know when + * an ident corresponds to a typedef or an ident. This normally means that + * we must call cpp on the file and have the lexer and parser cooperate + * to remember what is what. In lang_cpp/ we want to parse as-is, + * which means we need to infer back whether an identifier is + * a typedef or not. + * + * In this module we use a view that is more convenient for + * typedefs detection. We got rid of: + * - template arguments (see find_template_commentize()) + * - qualifiers (see find_qualifier_commentize) + * - differences between & and * (filter_for_typedef() below) + * - differences between TIdent and TOperator, + * - const, volatile, restrict keywords + * - TODO merge multiple ** or *& or whatever + * + * history: + * - We used to make the lexer and parser cooperate in a lexerParser.ml file + * - this was not enough because of declarations such as 'acpi acpi;' + * and so we had to enable/disable the ident->typedef mechanism + * which requires even more lexer/parser cooperation + * - this was ugly too so now we use a typedef "inference" mechanism + * - we refined the typedef inference to sometimes use InParameter hint + * and more contextual information from token_views_context.ml + *) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let look_like_multiplication_context tok_before = + match tok_before with + | TEq _ | TAssign _ + | TWhy _ + | Treturn _ + | TDot _ | TPtrOp _ | TPtrOpStar _ | TDotStar _ + | TOCro _ + -> true + | tok when TH.is_binary_operator_except_star tok -> true + | _ -> false + +let look_like_declaration_context tok_before = + match tok_before with + | TOBrace _ + | TPtVirg _ + | TCommentNewline_DefineEndOfMacro _ + | TInclude _ + (* no!! | TCBrace _, I think because of nested struct so can have + * struct { ... } v; + *) + -> true + | _ when TH.is_privacy_keyword tok_before -> true + | _ -> false + +let fakeInfo = { Parse_info. + token = Parse_info.FakeTokStr ("",None); + transfo = Parse_info.NoTransfo; + } + +(*****************************************************************************) +(* Better View *) +(*****************************************************************************) + +let filter_for_typedef multi_groups = + + (* a sentinel, which helps a few typedef heuristics which look + * for a token before which would not work for the first toplevel + * declaration. + *) + let multi_groups = + Tok(mk_token_fake (TPtVirg (fakeInfo)))::multi_groups in + + let _template_args = ref [] in + + (* remove template and other things + * less: right now this is less useful because we actually + * comment template args in a previous pass, but at some point this + * will be useful. + *) + let rec aux xs = + xs +> Common.map_filter (function + | TV.Angle (_, _, _) -> + (* todo: analayze xs!! add in _template_args + * todo: add the t1,t2 around xs to have + * some sentinel for the typedef heuristics patterns + * who often look for the token just before the typedef. + *) + None + | TV.Braces (t1, xs, t2) -> + Some (TV.Braces (t1, aux xs, t2)) + | TV.Parens (t1, xs, t2) -> + Some (TV.Parens (t1, aux xs, t2)) + + (* remove other noise for the typedef inference *) + | TV.Tok t1 -> + match t1.TV.t with + (* const is a strong signal for having a typedef, so why skip it? + * because it forces to duplicate rules. We need to infer + * the type anyway even when there is no const around. + * todo? maybe could do a special pass first that infer typedef + * using only const rules, and then remove those const so + * have best of both worlds. + *) + | Tconst _ | Tvolatile _ + | Trestrict _ + -> None + + | Tregister _ | Tstatic _ | Tauto _ | Textern _ + | Ttypedef _ + -> None + + | Tvirtual _ | Tfriend _ | Tinline _ | Tmutable _ + -> None + + (* let's transform all '&' into '*' + * todo: need propagate also the where? + *) + | TAnd ii -> Some (TV.Tok (mk_token_extended (TMul ii))) + + (* and operator into TIdent + * TODO: skip the token just after the operator keyword? + * could help some heuristics too + *) + | Toperator ii -> + Some (TV.Tok (mk_token_extended (TIdent ("operator", ii)))) + + | _ -> Some (TV.Tok t1) + ) + in + let xs = aux multi_groups in + (* todo: look also for _template_args *) + [TV.tokens_of_multi_grouped xs] + +(*****************************************************************************) +(* Main heuristics *) +(*****************************************************************************) + +(* + * Below we assume a view without: + * - comments and cpp-directives + * - template stuff and qualifiers (but not TIdent_ClassnameAsQualifier) + * - const/volatile/restrict + * - & => * + * + * With such a view we can write less patterns. + * + * Note that qualifiers are slightly less important to filter because + * most of the heuristics below look for tokens after the ident + * and qualifiers are usually before. + * + * todo: do it on multi view? all those rules with TComma and TOPar + * are ugly. + *) +let find_typedefs xxs = + + let rec aux xs = + match xs with + | [] -> () + + (* struct x ... + * those identifiers (called tags) must not be transformed in typedefs *) + | {t=(Tstruct _ | Tunion _ | Tenum _ | Tclass _)}::{t=TIdent _}::xs -> + aux xs + + (* xx yy *) + | ({t=TIdent (s,i1)} as tok1)::{t=TIdent _}::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + + (* xx ( *yy )( *) + | ({t=TIdent (s,i1)} as tok1)::{t=TOPar _}::{t=TMul _} + ::{t=TIdent _}::{t=TCPar _}::({t=TOPar _} as tok2)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (tok2::xs) + (* xx* ( *yy )( *) + | ({t=TIdent (s,i1)} as tok1)::{t=TMul _}::{t=TOPar _}::{t=TMul _} + ::{t=TIdent _}::{t=TCPar _}::({t=TOPar _} as tok2)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (tok2::xs) + + (* xx ( *yy[x] )( *) + | ({t=TIdent (s,i1)} as tok1)::{t=TOPar _}::{t=TMul _} + ::{t=TIdent _}::{t=TOCro _}::_::{t=TCCro _}::{t=TCPar _}::({t=TOPar _} as tok2)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (tok2::xs) + (* xx* ( *yy[x] )( *) + | ({t=TIdent (s,i1)} as tok1)::{t=TMul _}::{t=TOPar _}::{t=TMul _} + ::{t=TIdent _}::{t=TOCro _}::_::{t=TCCro _}::{t=TCPar _}::({t=TOPar _} as tok2)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (tok2::xs) + + (* xx ( *yy[]) *) + | ({t=TIdent (s,i1)} as tok1)::{t=TOPar _}::{t=TMul _} + ::{t=TIdent _}::{t=TOCro _}::{t=TCCro _}::{t=TCPar _}::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + + (* + xx * yy *) + | {t=tok_before}::{t=TIdent (_s,_)}::{t=TMul _}::{t=TIdent _}::xs + when look_like_multiplication_context tok_before -> + aux xs + (* { xx * yy *) + | {t=tok_before}::({t=TIdent (s,i1)} as tok1)::{t=TMul _}::{t=TIdent _}::xs + when look_like_declaration_context tok_before -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + (* } xx * yy *) + (* because TCBrace is not anymore in look_like_declaration_context *) + | {t=TCBrace _}::({t=TIdent (s,i1)} as tok1)::{t=TMul _}::{t=TIdent _}::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + (* xx * yy + * could be a multiplication too, so need InParameter guard/ + * less: the InParameter has some FPs, so maybe better to + * rely on the spacing hint, see the rule below. + *) + | ({t=TIdent (s,i1);where=InParameter::_} as tok1)::{t=TMul _} + ::{t=TIdent _}::xs + -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + + (* xx *yy *) + | ({t=TIdent (s,i1);col=c0} as tok1)::{t=TMul _;col=c1}::{t=TIdent _;col=c2}::xs + when c2 = c1 + 1 && c1 >= c0 + String.length s + 1 + -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + (* xx* yy *) + | ({t=TIdent(s,i1);col=c0}as tok1)::{t=TMul _;col=c1}::{t=TIdent _;col=c2}::xs + when c1 = c0 + String.length s && c2 >= c1 + 2 + -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + + (* xx ** yy + * less could be a multiplication too, but with less probability + *) + | ({t=TIdent (s,i1)} as tok1)::{t=TMul _}::{t=TMul _}::{t=TIdent _}::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + + (* (xx) yy and not a if/while before '(' (and yy can also be a constant) *) + | {t=tok1}::{t=TOPar _}::({t=TIdent(s, i1)} as tok3)::{t=TCPar _} + ::{t = (TIdent _|TInt _|TString _|TFloat _|TTilde _|TOPar _) }::xs + when not (TH.is_stuff_taking_parenthized tok1) (* && line are the same?*)-> + change_tok tok3 (TIdent_Typedef (s, i1)); + (* todo? recurse on bigger ? *) + aux xs + (* todo: = (xx) ..., |= (xx) ..., (xx)~, ... *) + (* (xx){ gccext: kenccext: *) + | {t=tok1}::{t=TOPar _}::({t=TIdent(s, i1)} as tok3)::{t=TCPar _} + ::({t=TOBrace _} as tok5)::xs + when not (TH.is_stuff_taking_parenthized tok1) -> + change_tok tok3 (TIdent_Typedef (s, i1)); + aux (tok5::xs) + + + (* (xx * ), not that pointer function are ( *xx ), so star before. + * TODO: does not really need the closing paren? + * TODO: check that not InParameter or InArgument? + *) + | {t=TOPar _}::({t=TIdent(s, i1)} as tok3)::{t=TMul _}::{t=TCPar _}::xs -> + change_tok tok3 (TIdent_Typedef (s, i1)); + aux xs + (* (xx ** ) *) + | {t=TOPar _}::({t=TIdent(s, i1)} as tok3) + ::{t=TMul _}::{t=TMul _}::{t=TCPar _}::xs -> + change_tok tok3 (TIdent_Typedef (s, i1)); + aux xs + + (* xx* [,)] + * don't forget to recurse by reinjecting the comma or closing paren + *) + | ({t=TIdent(s, i1)} as tok1)::{t=TMul _} + ::({t=(TComma _| TCPar _)} as x)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (x::xs) + (* xx** [,)] *) + | ({t=TIdent(s, i1)} as tok1)::{t=TMul _}::{t=TMul _} + ::({t=(TComma _| TCPar _)} as x)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (x::xs) + (* xx*** [,)] *) + | ({t=TIdent(s, i1)} as tok1)::{t=TMul _}::{t=TMul _}::{t=TMul _} + ::({t=(TComma _| TCPar _)} as x)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (x::xs) + (* xx*[] [,)] *) + | ({t=TIdent(s, i1)} as tok1)::{t=TMul _}::{t=TOCro _}::{t=TCCro _} + ::({t=(TComma _| TCPar _)} as x)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (x::xs) + + + (* [(,] xx [),] where InParameter *) + (* hmmm: todo: some false positives on InParameter, see mini/constants.c, + * so now simpler to add a TIdent in the parameter_decl rule + *) + | {t=(TOPar _ | TComma _)}::({t=TIdent (s, i1); where=InParameter::_} as tok1) + ::({t=(TCPar _ | TComma _)} as tok2)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (tok2::xs) + + (* [(,] xx[X] [),] where InParameter *) + | {t=(TOPar _ | TComma _)} + ::({t=TIdent (s, i1); where=InParameter::_} as tok1) + ::{t=TOCro _}::_::{t=TCCro _} + ::({t=(TCPar _ | TComma _)} as tok2)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux (tok2::xs) + + (* [(,] xx[...] could be a array access, so need InParameter guard *) + | {t=(TOPar _ | TComma _)}::({t=TIdent (s,i1);where=InParameter::_} as tok1) + ::{t=TOCro _}::_tok::{t=TCCro _}::xs + -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + + (* kencc-ext: xx; where InStruct *) + | {t=tok_before}::({t=TIdent (s, i1)} as tok1)::({t=TPtVirg _} as tok2)::xs + when look_like_declaration_context tok_before -> + (match tok1.where with + | (InClassStruct _)::_ -> + change_tok tok1 (TIdent_Typedef (s, i1)); + | _ -> () + ); + aux (tok2::xs) + + (* sizeof(xx) sizeof expr does not require extra parenthesis, but + * in practice people do, so guard it with what looks_like_typedef + *) + | {t=Tsizeof _}::{t=TOPar _}::({t=TIdent (s, i1)} as tok1)::{t=TCPar _}::xs + when Token_views_context.look_like_typedef s || s =~ "^[A-Z].*" -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + + (* new Xxx *) + | {t=Tnew _}::({t=TIdent (s, i1)} as tok1)::xs -> + change_tok tok1 (TIdent_Typedef (s, i1)); + aux xs + + (* recurse *) + | _::xs -> aux xs + in + xxs +> List.iter aux diff --git a/lang_cpp/parsing/parsing_hacks_typedef.mli b/lang_cpp/parsing/parsing_hacks_typedef.mli new file mode 100644 index 0000000..de9deb1 --- /dev/null +++ b/lang_cpp/parsing/parsing_hacks_typedef.mli @@ -0,0 +1,9 @@ + +val filter_for_typedef: + Token_views_cpp.multi_grouped list -> Token_views_cpp.token_extended list list + +(* We use a list list because the template arguments are passed separately + * TODO: right now we actually skip template arguments ... + *) +val find_typedefs: + Token_views_cpp.token_extended list list -> unit diff --git a/lang_cpp/parsing/parsing_recovery_cpp.ml b/lang_cpp/parsing/parsing_recovery_cpp.ml new file mode 100644 index 0000000..7ba60c3 --- /dev/null +++ b/lang_cpp/parsing/parsing_recovery_cpp.ml @@ -0,0 +1,140 @@ +(* Yoann Padioleau + * + * Copyright (C) 2011 Facebook + * Copyright (C) 2006, 2007, 2008 Ecole des Mines de Nantes + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module T = Parser_cpp +module TH = Token_helpers_cpp +module PI = Parse_info + +(*****************************************************************************) +(* Wrappers *) +(*****************************************************************************) +let pr2_err, _pr2_once = Common2.mk_pr2_wrappers Flag_parsing_cpp.verbose_parsing + +let pr2_err s = pr2_err ("ERROR_RECOV: " ^s) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +(*****************************************************************************) +(* Skipping stuff, find next "synchronisation" point *) +(*****************************************************************************) + +(* todo: do something if find T.Eof ? *) +let rec find_next_synchro ~next ~already_passed = + + (* Maybe because not enough }, because for example an ifdef contains + * in both branch some opening {, we later eat too much, "on deborde + * sur la fonction d'apres". So already_passed may be too big and + * looking for next synchro point starting from next may not be the + * best. So maybe we can find synchro point inside already_passed + * instead of looking in next. + * + * But take care! must progress. We must not stay in infinite loop! + * For instance now I have as a error recovery to look for + * a "start of something", corresponding to start of function, + * but must go beyond this start otherwise will loop. + * So look at premier(external_declaration2) in parser.output and + * pass at least those first tokens. + * + * I have chosen to start search for next synchro point after the + * first { I found, so quite sure we will not loop. *) + + let last_round = List.rev already_passed in + let is_define = + let xs = last_round +> List.filter TH.is_not_comment in + match xs with + | T.TDefine _::_ -> true + | _ -> false + in + if is_define + then find_next_synchro_define (last_round @ next) [] + else + + let (before, after) = + last_round +> Common.span (fun tok -> + match tok with + (* by looking at TOBrace we are sure that the "start of something" + * will not arrive too early + *) + | T.TOBrace _ -> false + | T.TDefine _ -> false + | _ -> true + ) + in + find_next_synchro_orig (after @ next) (List.rev before) + + + +and find_next_synchro_define next already_passed = + match next with + | [] -> + pr2_err "end of file while in recovery mode"; + already_passed, [] + | (T.TCommentNewline_DefineEndOfMacro _ as v)::xs -> + pr2_err (spf "found sync end of #define at line %d" (TH.line_of_tok v)); + v::already_passed, xs + | v::xs -> + find_next_synchro_define xs (v::already_passed) + + + + +and find_next_synchro_orig next already_passed = + match next with + | [] -> + pr2_err "end of file while in recovery mode"; + already_passed, [] + + | (T.TCBrace i as v)::xs when PI.col_of_info i = 0 -> + pr2_err (spf "found sync '}' at line %d" (PI.line_of_info i)); + + (match xs with + | [] -> raise Impossible (* there is a EOF token normally *) + + (* still useful: now parser.mly allow empty ';' so normally no pb *) + | T.TPtVirg iptvirg::xs -> + pr2_err "found sync bis, eating } and ;"; + (T.TPtVirg iptvirg)::v::already_passed, xs + + | T.TIdent x::T.TPtVirg iptvirg::xs -> + pr2_err "found sync bis, eating ident, }, and ;"; + (T.TPtVirg iptvirg)::(T.TIdent x)::v::already_passed, + xs + + | T.TCommentSpace sp::T.TIdent x::T.TPtVirg iptvirg + ::xs -> + pr2_err "found sync bis, eating ident, }, and ;"; + (T.TCommentSpace sp):: + (T.TPtVirg iptvirg):: + (T.TIdent x):: + v:: + already_passed, + xs + + | _ -> + v::already_passed, xs + ) + | v::xs -> + let info = TH.info_of_tok v in + if PI.col_of_info info = 0 && TH.is_start_of_something v + then begin + pr2_err (spf "found sync col 0 at line %d " (PI.line_of_info info)); + already_passed, v::xs + end + else find_next_synchro_orig xs (v::already_passed) + + diff --git a/lang_cpp/parsing/parsing_recovery_cpp.mli b/lang_cpp/parsing/parsing_recovery_cpp.mli new file mode 100644 index 0000000..27d0c04 --- /dev/null +++ b/lang_cpp/parsing/parsing_recovery_cpp.mli @@ -0,0 +1,5 @@ + +val find_next_synchro: + next:Parser_cpp.token list -> + already_passed:Parser_cpp.token list -> + Parser_cpp.token list * Parser_cpp.token list diff --git a/lang_cpp/parsing/pp_token.ml b/lang_cpp/parsing/pp_token.ml new file mode 100644 index 0000000..6f807e0 --- /dev/null +++ b/lang_cpp/parsing/pp_token.ml @@ -0,0 +1,235 @@ +(* Yoann Padioleau + * + * Copyright (C) 2007, 2008 Ecole des Mines de Nantes + * Copyright (C) 2011 Facebook + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) + +open Common + +module Ast = Ast_cpp +module Flag = Flag_parsing_cpp +module TH = Token_helpers_cpp +module Parser = Parser_cpp +module Hack = Parsing_hacks_lib + +open Parser_cpp +open Token_views_cpp + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(* + * CPP functions working at the token level. See pp_ast.ml for cpp functions + * working at the AST level (which is very unusual but makes sense in + * the coccinelle context for instance). + * + * Note that because I use a single lexer to work both at the C and cpp level + * there are some inconveniencies. + * For instance 'for' is a valid name for a macro parameter and macro + * body, but is interpreted in a special way by our single lexer, and + * so at some places where I expect a TIdent I need also to + * handle special cases and accept Tfor, Tif, etc at those places. + * + * There are multiple issues related to those keywords incorrect tokens. + * Those keywords can be: + * + * - (1) in the name of the macro as in #define inline + * - (2) in a parameter of the macro as in #define foo(char) char x; + * - (3) in an argument to a macro call as in IDENT(if); + * + * Case 1 is easy to fix in define_ident in ??? + * + * Case 2 is easy to fix in define_parse below, where we detect such tokens + * in the parameters and then replace their occurence in the body with + * a TIdent. + * + * Case 3 is only an issue when the expanded token is not really used + * as usual but used for instance in concatenation as in a ## if + * when expanded. In the case the grammar this time will not be happy + * so this is also easy to fix in cpp_engine. + *) + +(*****************************************************************************) +(* Wrappers *) +(*****************************************************************************) +let pr2, _pr2_once = Common2.mk_pr2_wrappers Flag_parsing_cpp.verbose_parsing + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* the tokens in the body of the macro are all ExpandedTok *) +type define_body = (unit,string list) either * Parser_cpp.token list + +(* TODO: +type define_def = string * define_param * define_body + and define_param = + | NoParam + | Params of string list + and define_body = + | DefineBody of Parser_c.token list + | DefineHint of parsinghack_hint + + and parsinghack_hint = + | HintIterator + | HintDeclarator + | HintMacroString + | HintMacroStatement + | HintAttribute + | HintMacroIdentBuilder +*) + + +(*****************************************************************************) +(* Apply macro (using standard.h or other defs) *) +(*****************************************************************************) +(* cpp-builtin part1, macro, using standard.h or other defs *) + +(* Thanks to this function many stuff are not anymore hardcoded in + * OCaml code (but are now hardcoded in standard.h ...) + *) +let (cpp_engine: + (string , Parser.token list) assoc -> Parser.token list -> Parser.token list) + = fun env xs -> + xs +> List.map (fun tok -> + match tok with + | TIdent (s,_i1) when List.mem_assoc s env -> Common2.assoc s env + | x -> [x] + ) + +> List.flatten + +(* + * We apply a macro by generating new ExpandedToken and by + * commenting the old macro call. + * + * no need to take care to substitute the macro name itself + * that occurs in the macro definition because the macro name is + * after fix_token_define a TDefineIdent, no more a TIdent. + *) +let apply_macro_defs defs xs = + + let rec apply_macro_defs xs = + match xs with + | [] -> () + + (* recognized macro of standard.h (or other) *) + | PToken ({t=TIdent (s,_i1);_} as id)::Parenthised (xxs,info_parens)::xs + when Hashtbl.mem defs s -> + Hack.pr2_pp ("MACRO: found known macro = " ^ s); + (match Hashtbl.find defs s with + | Left (), bodymacro -> + pr2 ("macro without param used before parenthize, wierd: " ^ s); + (* ex: PRINTP("NCR53C400 card%s detected\n" ANDP(((struct ... *) + Hack.set_as_comment (Token_cpp.CppMacroExpanded) id; + id.new_tokens_before <- bodymacro; + | Right params, bodymacro -> + if List.length params = List.length xxs + then + let xxs' = xxs +> List.map (fun x -> + (tokens_of_paren_ordered x) +> List.map (fun x -> + TH.visitor_info_of_tok Ast.make_expanded x.t + ) + ) in + id.new_tokens_before <- + cpp_engine (Common2.zip params xxs') bodymacro + + else begin + pr2 ("macro with wrong number of arguments, wierd: " ^ s); + id.new_tokens_before <- bodymacro; + end; + (* important to do that after have apply the macro, otherwise + * will pass as argument to the macro some tokens that + * are all TCommentCpp + *) + [Parenthised (xxs, info_parens)] +> + iter_token_paren (Hack.set_as_comment Token_cpp.CppMacroExpanded); + Hack.set_as_comment Token_cpp.CppMacroExpanded id; + + + + ); + apply_macro_defs xs + + | PToken ({t=TIdent (s,_i1);_} as id)::xs + when Hashtbl.mem defs s -> + Hack.pr2_pp ("MACRO: found known macro = " ^ s); + (match Hashtbl.find defs s with + | Right _params, _bodymacro -> + pr2 ("macro with params but no parens found, wierd: " ^ s); + (* dont apply the macro, perhaps a redefinition *) + () + | Left (), bodymacro -> + (* special case when 1-1 substitution, we reuse the token *) + (match bodymacro with + | [newtok] -> + id.t <- (newtok +> TH.visitor_info_of_tok (fun _ -> + TH.info_of_tok id.t)) + + | _ -> + Hack.set_as_comment Token_cpp.CppMacroExpanded id; + id.new_tokens_before <- bodymacro; + ) + ); + apply_macro_defs xs + + (* recurse *) + | (PToken _x)::xs -> apply_macro_defs xs + | (Parenthised (xxs, _info_parens))::xs -> + xxs +> List.iter apply_macro_defs; + apply_macro_defs xs + + in + apply_macro_defs xs + +(*****************************************************************************) +(* Extracting macros (from a standard.h) *) +(*****************************************************************************) + +(* assumes have called fix_tokens_define before, so have TOPar_Define *) +let rec define_parse xs = + match xs with + | [] -> [] + | TDefine _i1::TIdent_Define (s,_i2)::TOPar_Define _i3::xs -> + let (tokparams, _, xs) = + xs +> Common2.split_when (function TCPar _ -> true | _ -> false) in + let (body, _, xs) = + xs +> Common2.split_when + (function TCommentNewline_DefineEndOfMacro _ -> true | _ -> false) in + let params = + tokparams +> Common.map_filter (function + | TComma _ -> None + | TIdent (s, _) -> Some s + | x -> Common2.error_cant_have x + ) in + let body = body +> List.map + (TH.visitor_info_of_tok Ast.make_expanded) in + let def = (s, (Right params, body)) in + def::define_parse xs + + | TDefine _i1::TIdent_Define (s,_i2)::xs -> + let (body, _, xs) = + xs +> Common2.split_when + (function TCommentNewline_DefineEndOfMacro _ -> true | _ -> false) in + let body = body +> List.map + (TH.visitor_info_of_tok Ast.make_expanded) in + let def = (s, (Left (), body)) in + def::define_parse xs + + | TDefine _i1::_ -> + raise Impossible + | _x::xs -> define_parse xs + + +let extract_macros xs = + let cleaner = xs +> List.filter (fun x -> not (TH.is_comment x)) in + define_parse cleaner diff --git a/lang_cpp/parsing/pp_token.mli b/lang_cpp/parsing/pp_token.mli new file mode 100644 index 0000000..a086a70 --- /dev/null +++ b/lang_cpp/parsing/pp_token.mli @@ -0,0 +1,59 @@ +(* Expanding or extracting macros, at the token level *) + +(* the either is to differentialte macro-variables from macro-functions *) +type define_body = (unit,string list) Common.either * Parser_cpp.token list + +(* TODO +(* corresponds to what is in the yacfe configuration file (e.g. standard.h) *) +type define_def = string * define_param * define_body + and define_param = + | NoParam + | Params of string list + and define_body = + | DefineBody of Parser_c.token list + | DefineHint of parsinghack_hint + + (* strongly corresponds to the TMacroXxx in the grammar and lexer and the + * MacroXxx in the ast. + *) + and parsinghack_hint = + | HintIterator + | HintDeclarator + | HintMacroString + | HintMacroStatement + | HintAttribute + | HintMacroIdentBuilder + +*) + + +(* extracting define_def, e.g. from a standard.h; assume have called + * fix_tokens_define before to have the TDefEol *) +val extract_macros: + Parser_cpp.token list -> (string, define_body) Common.assoc + +(* TODO +val string_of_define_def: define_def -> string +*) + +(* used internally *) +(* This function work by side effect and may generate new tokens + * in the new_tokens_before field of the token_extended in the + * paren_grouped list. So don't forget to recall + * Token_views_c.rebuild_tokens_extented after this call, as well + * as probably insert_virtual_positions as new tokens + * are generated. + * + * note: it does not do some fixpoint, so the generated code may also + * contain some macros names. + *) + +val apply_macro_defs: +(* + msg_apply_known_macro:(string -> unit) -> + msg_apply_known_macro_hint:(string -> unit) -> + ?evaluate_concatop:bool -> + ?inplace_when_single:bool -> +*) + (string, define_body (* define_def *)) Hashtbl.t -> + Token_views_cpp.paren_grouped list -> unit diff --git a/lang_cpp/parsing/test_dump_nim.ml b/lang_cpp/parsing/test_dump_nim.ml new file mode 100644 index 0000000..a744b34 --- /dev/null +++ b/lang_cpp/parsing/test_dump_nim.ml @@ -0,0 +1,871 @@ +open Common + +open Parse_info +open Ast_cpp + +module Flag = Flag_parsing_cpp + +let process_either _of_a _of_b = + function + | Left left -> "" ^ _of_a left + | Right right -> "" ^ _of_b right + + +let process_option ofa x = + match x with + | None -> "" + | Some stuff -> "" ^ ofa stuff + +let process_list _of_a node = + let map = List.map _of_a node + in String.concat ", " map + + +let rec process_info token = + process_token token + +and process_token tok = + match tok.token with + | OriginTok loc -> loc.str + | FakeTokStr (v1, opt) -> "" + | Ab -> "" + | ExpandedTok (tok1, tok2, integer) -> tok1.str + +and wrap _of_a (v1, v2) = + _of_a v1 + +and wrap2 _of_a (v1, v2) = + let v1 = _of_a v1 and v2 = process_info v2 in + v1 ^ v2 + +and process_paren _of_a (paren1, arglist, paren2) = + let paren1 = process_token paren1 + and arglist = _of_a arglist + and paren2 = process_token paren2 + in paren1 ^ arglist ^ paren2 + +and process_brace _of_a (br1, arglist, br2) = + _of_a arglist + +and process_bracket _of_a (br1, arglist, br2) = + let br1 = process_token br1 + and arglist = _of_a arglist + and br2 = process_token br2 in + br1 ^ arglist ^ br2 + +and process_angle _of_a (ang1, args, ang2) = + let ang1 = process_token ang1 + and args = _of_a args + and ang2 = process_token ang2 + in ang1 ^ args ^ ang2 + +and process_comma_list _of_a node = + process_list (wrap _of_a) node + +and process_comma_list2 _of_a = + process_list (process_either _of_a process_token) + +let rec process_token tok = + match tok.token with + | OriginTok loc -> loc.str + | FakeTokStr (v1, opt) -> "" + | Ab -> "" + | ExpandedTok (tok1, tok2, integer) -> tok1.str + +and process_include_kind = function + | Local -> "" + | Standard -> "" + | Weird -> "" + +and process_define_expr expr = + "" +and process_constant = + function + | String (str, is_wchar) -> str + | MultiString -> "" + | Char (str, is_wchar) -> str + | Int str -> str + | Float (str, ftype) -> str + | Bool bval -> string_of_bool bval + +and process_ident ident = + match ident with + | IdIdent (name, tok) -> + process_token tok + | IdTemplateId (ident, args) -> + "" + | IdDestructor (tok, simple_ident) -> + let (_, idtok) = simple_ident in + "destructor" ^ process_token idtok + | IdOperator (tok, operator) -> + "" + | IdConverter (tok, fullType) -> + "" + +and process_argument arg = + process_either process_expression process_weird_arg arg + +and process_weird_arg = + function + | ArgType arg_type -> process_fullType arg_type + | ArgAction arg_action -> process_action_macro arg_action + +and process_action_macro = + function + | ActMisc act_misc -> + process_list process_token act_misc + +and process_typeC (tc, tok_list) = + process_typeCbis tc + +and process_floatType = + function + | CFloat -> "cfloat" + | CDouble -> "cdouble" + | CLongDouble -> "clongdouble" + +and process_intType = + function + | CChar -> "cchar" + | Si signed -> process_signed signed + | CBool -> "cbool" + | WChar_t -> "cwchar_t" + +and process_signed (sign, base) = + let sign = process_sign sign and base = process_base base + in "c" ^ sign ^ base (* cuchar, cint, cuint, etc. *) + +and process_base = + function + | CChar2 -> "char" + | CShort -> "short" + | CInt -> "int" + | CLong -> "long" + | CLongLong -> "longlong" +and process_sign = + function + | Signed -> "" + | UnSigned -> "u" + + +and process_baseType = + function + | Void -> "void" + | IntType intType -> process_intType intType + | FloatType floatType -> process_floatType floatType + +and process_param_name = + function + | None -> "" + | Some (name, tok) -> process_token tok ^ ": " + +and process_parameter { + p_name = p_name; + p_type = p_type; + p_register = p_register; + p_val = p_val + } = + let type_str = process_fullType p_type + and p_name = process_param_name p_name in + p_name ^ type_str + +and process_functionType { + ft_ret = ft_ret; + ft_params = ft_params; + ft_dots = ft_dots; + ft_const = ft_const; + ft_throw = ft_throw + } = + let ret_type = process_fullType ft_ret + and paren_str = + process_paren (process_comma_list process_parameter) ft_params in + paren_str ^ ": " ^ ret_type + +and process_simple_ident (name, tok) = + process_token tok + +and process_e_val (tok, cexpr) = + let equals = process_token tok (* equals sign *) + and cexpr = process_constExpression cexpr (* const expr *) + in " " ^ equals ^ " " ^ cexpr + +and process_enum_elem { e_name = e_name; e_val = e_val } = + let e_name = process_simple_ident e_name + and e_val = process_option process_e_val e_val in + e_name ^ e_val + +and process_constExpression expr = process_expression expr + +and process_template_arguments args = + process_angle (process_comma_list process_template_argument) args + +and process_template_argument arg = + process_either process_fullType process_expression arg + +and process_qualifier = + function + | QClassname ((name, info)) -> + name ^ process_info info + | QTemplateId ((name, args)) -> + let ident = process_simple_ident name + and args = process_template_arguments args in + ident ^ args + +and process_name (v1, v2, v3) = + let v1 = process_option process_token v1 + and v2 = + process_list + (fun (v1, v2) -> + let v1 = process_qualifier v1 + and v2 = process_token v2 in + v1 ^ v2) + v2 + and v3 = process_ident v3 + in v1 ^ v2 ^ v3 + +and process_either_ft_or_expr ft_or_expr = + process_either process_fullType process_expression ft_or_expr + +and process_structUnion = + function + | Struct -> "struct" + | Union -> "union" + | Class -> "class" + +and process_typeCbis = + function + | BaseType btype -> + process_baseType btype + | Pointer point -> + "ptr " ^ process_fullType point + | Reference ref -> + "ref " ^ process_fullType ref + | Array ((arr, typ)) -> + let arr = process_bracket (process_option process_constExpression) arr + and typ = process_fullType typ + in arr ^ typ + | FunctionType ftype -> + process_functionType ftype + | EnumDef ((name, ident, elements)) -> + let ident = process_option process_simple_ident ident + and elements = + process_brace (process_comma_list process_enum_elem) elements + in ident ^ " = enum\n" ^ elements + | StructDef sdef -> + "" (*process_class_definition sdef*) + | EnumName ((enum, name)) -> + process_simple_ident name + | StructUnionName ((stype_tok, name)) -> + let (stype, _) = stype_tok in + let stype = process_structUnion stype + and name = process_simple_ident name in + stype ^ " " ^ name + | TypeName ((tname)) -> + process_name tname + | TypenameKwd ((tname (* 'typename' *), tdef_name)) -> + process_name tdef_name + | TypeOf ((typeof, tdef)) -> + process_paren process_either_ft_or_expr tdef + | ParenType paren -> + process_paren process_fullType paren + +and process_info token = + process_token token + +and process_expression (expr, toks) = + process_exprbis expr + +and process_exprbis = + function + | Id ((name, info)) -> + let (_, _, ident) = name in + process_ident ident + | C const -> process_constant const + | Call ((expr, args)) -> + let name = process_expression expr + and args = process_paren (process_comma_list process_argument) args + in name ^ args + | CondExpr ((v1, v2, v3)) -> + (*let v1 = vof_expression v1 + and v2 = Ocaml.vof_option vof_expression v2 + and v3 = vof_expression v3*) + "" + | Sequence ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("Sequence", [ v1; v2 ]))*) + "" + | Assignment ((v1, v2, v3)) -> + (*let v1 = vof_expression v1 + and v2 = vof_assignOp v2 + and v3 = vof_expression v3 + in Ocaml.VSum (("Assignment", [ v1; v2; v3 ]))*) + "" + | Postfix ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_fixOp v2 + in Ocaml.VSum (("Postfix", [ v1; v2 ]))*) + "" + | Infix ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_fixOp v2 + in Ocaml.VSum (("Infix", [ v1; v2 ]))*) + "" + | Unary ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_unaryOp v2 + in Ocaml.VSum (("Unary", [ v1; v2 ]))*) + "" + | Binary ((v1, v2, v3)) -> + (*let v1 = vof_expression v1 + and v2 = vof_binaryOp v2 + and v3 = vof_expression v3 + in Ocaml.VSum (("Binary", [ v1; v2; v3 ]))*) + "" + | ArrayAccess ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_bracket vof_expression v2 + in Ocaml.VSum (("ArrayAccess", [ v1; v2 ]))*) + "" + | RecordAccess ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_name v2 + in Ocaml.VSum (("RecordAccess", [ v1; v2 ]))*) + "" + | RecordPtAccess ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_name v2 + in Ocaml.VSum (("RecordPtAccess", [ v1; v2 ]))*) + "" + | RecordStarAccess ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("RecordStarAccess", [ v1; v2 ]))*) + "" + | RecordPtStarAccess ((v1, v2)) -> + (*let v1 = vof_expression v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("RecordPtStarAccess", [ v1; v2 ]))*) + "" + | SizeOfExpr ((v1, v2)) -> + (*let v1 = vof_tok v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("SizeOfExpr", [ v1; v2 ]))*) + "" + | SizeOfType ((v1, v2)) -> + (*let v1 = vof_tok v1 + and v2 = vof_paren vof_fullType v2 + in Ocaml.VSum (("SizeOfType", [ v1; v2 ]))*) + "" + | Cast ((v1, v2)) -> + (*let v1 = vof_paren vof_fullType v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("Cast", [ v1; v2 ]))*) + "" + | StatementExpr v1 -> + (*let v1 = vof_paren vof_compound v1 + in Ocaml.VSum (("StatementExpr", [ v1 ]))*) + "" + | GccConstructor ((v1, v2)) -> + (*let v1 = vof_paren vof_fullType v1 + and v2 = vof_brace (vof_comma_list vof_initialiser) v2 + in Ocaml.VSum (("GccConstructor", [ v1; v2 ]))*) + "" + | This v1 -> + (*let v1 = vof_tok v1 in Ocaml.VSum (("This", [ v1 ]))*) + "" + | ConstructedObject ((v1, v2)) -> + (*let v1 = vof_fullType v1 + and v2 = vof_paren (vof_comma_list vof_argument) v2 + in Ocaml.VSum (("ConstructedObject", [ v1; v2 ]))*) + "" + | TypeId ((v1, v2)) -> + (*let v1 = vof_tok v1 + and v2 = vof_paren vof_either_ft_or_expr v2 + in Ocaml.VSum (("TypeId", [ v1; v2 ]))*) + "" + | CplusplusCast ((v1, v2, v3)) -> + (*let v1 = vof_wrap2 vof_cast_operator v1 + and v2 = vof_angle vof_fullType v2 + and v3 = vof_paren vof_expression v3 + in Ocaml.VSum (("CplusplusCast", [ v1; v2; v3 ]))*) + "" + | New ((v1, v2, v3, v4, v5)) -> + (*let v1 = Ocaml.vof_option vof_tok v1 + and v2 = vof_tok v2 + and v3 = Ocaml.vof_option (vof_paren (vof_comma_list vof_argument)) v3 + and v4 = vof_fullType v4 + and v5 = Ocaml.vof_option (vof_paren (vof_comma_list vof_argument)) v5 + in Ocaml.VSum (("New", [ v1; v2; v3; v4; v5 ]))*) + "" + | Delete ((v1, v2)) -> + (*let v1 = Ocaml.vof_option vof_tok v1 + and v2 = vof_expression v2 + in Ocaml.VSum (("Delete", [ v1; v2 ]))*) + "" + | DeleteArray ((tok, expr)) -> + let tok = process_option process_token tok + and expr = process_expression expr + in tok ^ expr + | Throw throw -> + process_option process_expression throw + | ParenExpr paren_expr -> + process_paren process_expression paren_expr + | ExprTodo -> "TODO" + +and process_selection = + function + | If ((v1, v2, v3, v4, v5)) -> + let v1 = process_token v1 + and v2 = process_paren process_expression v2 + and v3 = process_statement v3 + and v4 = process_option process_token v4 + and v5 = process_statement v5 + in v1 ^ v2 ^ v3 ^ v4 ^v5 + | Switch ((v1, v2, v3)) -> + let v1 = process_token v1 + and v2 = process_paren process_expression v2 + and v3 = process_statement v3 + in v1 ^ v2 ^ v3 +and process_iteration = + function + | While ((v1, v2, v3)) -> + let v1 = process_token v1 + and v2 = process_paren process_expression v2 + and v3 = process_statement v3 + in v1 ^ v2 ^ v3 + | DoWhile ((v1, v2, v3, v4, v5)) -> + let v1 = process_token v1 + and v2 = process_statement v2 + and v3 = process_token v3 + and v4 = process_paren process_expression v4 + and v5 = process_token v5 + in v1 ^ v2 ^ v3 ^ v4 ^v5 + | For ((v1, v2, v3)) -> + let v1 = process_token v1 + and v2 = + process_paren + (fun (v1, v2, v3) -> + let v1 = wrap process_exprStatement v1 + and v2 = wrap process_exprStatement v2 + and v3 = wrap process_exprStatement v3 + in v1 ^ v2 ^ v3) + v2 + and v3 = process_statement v3 + in v1 ^ v2 ^ v3 + | MacroIteration ((v1, v2, v3)) -> + let v1 = process_simple_ident v1 + and v2 = process_paren (process_comma_list process_argument) v2 + and v3 = process_statement v3 + in v1 ^ v2 ^ v3 +and process_jump = + function + | Goto goto -> "# XXX goto not supported: " ^ goto + | Continue -> "continue" + | Break -> "break" + | Return -> "return" + | ReturnExpr ret_expr -> + process_expression ret_expr + | GotoComputed goto_comp -> + "#[ XXX goto not supported: " ^ process_expression goto_comp ^ "]#" + +and process_handler (v1, v2, v3) = + let v1 = process_token v1 + and v2 = process_paren process_exception_declaration v2 + and v3 = process_compound v3 + in v1 ^ v2 ^ v3 + +and process_exception_declaration = + function + | ExnDeclEllipsis exn_ellipsis -> + process_token exn_ellipsis + | ExnDecl exn_decl -> + process_parameter exn_decl + +and get_tydef_prefix name storage = + match storage with + | NoSto -> "" + | StoTypedef st_tdef -> + "type " ^ name ^ " = " + | Sto (sto, tok) -> "" + +and process_onedecl { + v_namei = v_namei; + v_type = v_type; + v_storage = v_storage + } = + let name = + process_option + (fun (name, init) -> + let name = process_name name + and init = process_option process_init init + in name ^ init) + v_namei in + let res = process_onedeclFullType "" name v_storage v_type in + res + +and process_onedeclFullType prefix name storage (qualifier, (typeCbis, tok_list)) = + match typeCbis with + | BaseType btype -> + process_baseType btype + | Pointer point -> + process_onedeclFullType "ptr " name storage point + | Reference ref -> + process_onedeclFullType "ref " name storage ref + | Array ((arr, typ)) -> + let arr = process_bracket (process_option process_constExpression) arr + and typ = process_fullType typ + in arr ^ typ + | FunctionType ftype -> + let ret = match storage with + | NoSto -> "proc " ^ name ^ process_functionType ftype + | StoTypedef st_tdef -> + "type " ^ name ^ " = " ^ "proc " ^ process_functionType ftype + | Sto sto -> "proc " ^ name ^ process_functionType ftype in + ret + | EnumDef ((name, ident, elements)) -> + let ident = process_option process_simple_ident ident + and elements = + process_brace (process_comma_list process_enum_elem) elements + in "type " ^ ident ^ " = enum " ^ elements + | StructDef sdef -> + "" (*process_class_definition sdef*) + | EnumName ((enum, name)) -> + process_simple_ident name + | StructUnionName ((stype_tok, name)) -> + let (stype, _) = stype_tok in + let stype = process_structUnion stype + and name = process_simple_ident name in + stype ^ " " ^ name + | TypeName ((tname)) -> + process_name tname + | TypenameKwd ((tname (* 'typename' *), tdef_name)) -> + process_name tdef_name + | TypeOf ((typeof, tdef)) -> + process_paren process_either_ft_or_expr tdef + | ParenType (left, type_inf, right) -> + process_onedeclFullType "" name storage type_inf + +and process_storage st = process_storagebis st +and process_storagebis = + function + | NoSto -> "" + | StoTypedef st_tdef -> + process_token st_tdef + | Sto sto -> wrap2 process_storageClass sto + +and process_storageClass = + function + | Auto -> "auto" + | Static -> "static" + | Register -> "register" + | Extern -> "extern" + +and process_init = + function + | EqInit ((v1, v2)) -> + let v1 = process_token v1 + and v2 = process_initialiser v2 + in v1 ^ v2 + | ObjInit v1 -> + process_paren (process_comma_list process_argument) v1 + +and process_block_declaration = + function + | DeclList ((decl, semi_col)) -> + let v1 = process_comma_list process_onedecl decl + in "DECLLIST " ^ v1 + | MacroDecl ((v1, v2, v3, v4)) -> + let v1 = process_list process_token v1 + and v2 = process_simple_ident v2 + and v3 = process_paren (process_comma_list process_argument) v3 + and v4 = process_token v4 + in v1 ^ v2 ^ v3 ^ v4 + | UsingDecl v1 -> + let v1 = + (match v1 with + | (v1, v2, v3) -> + let v1 = process_token v1 + and v2 = process_name v2 + and v3 = process_token v3 + in v1 ^ v2 ^ v3) + in v1 + | UsingDirective ((v1, v2, v3, v4)) -> + let v1 = process_token v1 + and v2 = process_token v2 + and v3 = process_name v3 + and v4 = process_token v4 + in v1 ^ v2 ^ v3 ^ v4 + | NameSpaceAlias ((v1, v2, v3, v4, v5)) -> + let v1 = process_token v1 + and v2 = process_simple_ident v2 + and v3 = process_token v3 + and v4 = process_name v4 + and v5 = process_token v5 + in v1 ^ v2 ^ v3 ^ v4 ^ v5 + | Asm ((v1, v2, v3, v4)) -> + let v1 = process_token v1 + and v2 = process_option process_token v2 + and v3 = process_paren process_asmbody v3 + and v4 = process_token v4 + in v1 ^ v2 ^ v3 ^ v4 + +and process_asmbody (v1, v2) = + let v1 = process_list process_token v1 + and v2 = process_list (wrap process_colon) v2 + in v1 ^ v2 +and process_colon = + function + | Colon v1 -> + let v1 = process_comma_list process_colon_option v1 + in v1 +and process_colon_option v = wrap process_colon_optionbis v +and process_colon_optionbis = + function + | ColonMisc -> "colonmisc" + | ColonExpr v1 -> + let v1 = process_paren process_expression v1 + in v1 + +and process_statement stmt = wrap process_statementbis stmt +and process_statementbis = + function + | Compound comp -> + process_compound comp + | ExprStatement expr -> + process_exprStatement expr + | Labeled labeled -> + process_labeled labeled + | Selection selection -> + process_selection selection + | Iteration iter -> + process_iteration iter + | Jump jump -> + process_jump jump + | DeclStmt decl -> + process_block_declaration decl + | Try ((tok, comp, handler_list)) -> + let comp = process_compound comp + and handler_list = process_list process_handler handler_list + in "try: " ^ comp ^ handler_list + | NestedFunc nest_func -> + process_func_definition nest_func + | MacroStmt -> "" + | StmtTodo -> "# TODO" + +and process_compound comp = process_brace (process_list process_statement_sequencable) comp + +and process_statement_sequencable = + function + | StmtElem stmt -> + process_statement stmt + | CppDirectiveStmt direc -> + process_cpp_directive direc + | IfdefStmt ifdef -> + process_ifdef_directive ifdef + +and process_ifdef_directive if_def = wrap2 process_ifdefkind if_def +and process_ifdefkind = + function (* TODO fix this for Nim *) + | Ifdef -> "ifdef" + | IfdefElse -> "ifdefelse" + | IfdefElseif -> "ifdefelseif" + | IfdefEndif -> "ifdefendif" + +and process_exprStatement expr_stmt = + process_option process_expression expr_stmt + +and process_labeled = + function + | Label ((name, stmt)) -> + let stmt = process_statement stmt + in name ^ " " ^ stmt + | Case ((expr, stmt)) -> + let expr = process_expression expr + and stmt = process_statement stmt + in expr ^ " " ^stmt + | CaseRange ((expr1, expr2, stmt)) -> + let expr1 = process_expression expr1 + and expr2 = process_expression expr2 + and stmt = process_statement stmt + in expr1 ^ expr2 ^ stmt + | Default def -> + process_statement def + +and process_initialiser = + function + | InitExpr v1 -> + process_expression v1 + | InitList v1 -> + process_brace (process_comma_list process_initialiser) v1 + | InitDesignators ((v1, v2, v3)) -> + let v1 = process_list process_designator v1 + and v2 = process_token v2 + and v3 = process_initialiser v3 + in v1 ^ v2 ^ v3 + | InitFieldOld ((v1, v2, v3)) -> + let v1 = process_simple_ident v1 + and v2 = process_token v2 + and v3 = process_initialiser v3 + in v1 ^ v2 ^ v3 + | InitIndexOld ((v1, v2)) -> + let v1 = process_bracket process_expression v1 + and v2 = process_initialiser v2 + in v1 ^ v2 +and process_designator = + function + | DesignatorField ((v1, v2)) -> + let v1 = process_token v1 + and v2 = process_simple_ident v2 + in v1 ^ v2 + | DesignatorIndex v1 -> + process_bracket process_expression v1 + | DesignatorRange v1 -> + process_bracket + (fun (v1, v2, v3) -> + let v1 = process_expression v1 + and v2 = process_token v2 + and v3 = process_expression v3 + in v1 ^ v2 ^ v3) + v1 + +and process_define_val = + function + | DefinePrintWrapper ((if_tok, expr_paren, name)) -> + let expr_paren = process_paren process_expression expr_paren + and name = process_name name in + expr_paren ^ name + | DefineExpr expr -> + process_expression expr + | DefineStmt stmt -> + process_statement stmt + | DefineType dtype -> + process_fullType dtype + | DefineDoWhileZero (stmt, tok_list) -> + process_statement stmt + | DefineFunction dfunc -> + process_func_definition dfunc + | DefineInit init -> + process_initialiser init + | DefineText (str, toks) -> + str + | DefineEmpty -> "" + | DefineTodo -> "" + +and process_define _tok ident kind value = + match kind with + | DefineVar -> + let (idname, _ ) = ident in + "const " ^ idname ^ " = " ^ process_define_val value ^ "\n" + | DefineFunc func -> + "" + (*let (idname, _) = ident + in *) + +and process_include ((tok, kind, path)) = + let include_file = + match kind with + | Local -> path + | Standard -> path + | Weird -> + let search = Str.regexp "_" + and lower = String.lowercase_ascii path + in Str.global_replace search "." lower + in "#" ^ include_file ^ " " ^ process_token tok + +and process_cpp_directive = function + | Define ((tok, ident, kind, value)) -> + process_define tok ident kind value + | Include ((tok, inc_kind, path)) -> + process_include (tok, inc_kind, path) + | Undef ((name, tok)) -> + process_token tok + | PragmaAndCo tok -> + process_token tok + +and process_func_definition { + f_name = f_name; + f_type = f_type; + f_storage = f_storage; + f_body = f_body + } = + "" + +and process_func_or_else = + function + | FunctionOrMethod func_meth -> + process_func_definition func_meth + | Constructor ((func)) -> + process_func_definition func + | Destructor func -> + process_func_definition func + +and process_declaration = + function + | BlockDecl block -> + process_block_declaration block + | Func func -> + (*let v1 = vof_func_or_else v1 in Ocaml.VSum (("Func", [ v1 ]))*) + process_func_or_else func + | TemplateDecl (v1, v2, v3) -> + (*let v1 = vof_tok v1 + and v2 = vof_template_parameters v2 + and v3 = vof_declaration v3 + in Ocaml.VSum (("TemplateDecl", [ v1; v2; v3 ]))*) + "" + | TemplateSpecialization ((v1, v2, v3)) -> + (*let v1 = vof_tok v1 + and v2 = vof_angle Ocaml.vof_unit v2 + and v3 = vof_declaration v3 + in Ocaml.VSum (("TemplateSpecialization", [ v1; v2; v3 ]))*) + "" + | ExternC ((v1, v2, v3)) -> + (*let v1 = vof_tok v1 + and v2 = vof_tok v2 + and v3 = vof_declaration v3 + in Ocaml.VSum (("ExternC", [ v1; v2; v3 ]))*) + "" + | ExternCList ((v1, v2, v3)) -> + (*let v1 = vof_tok v1 + and v2 = vof_tok v2 + and v3 = vof_brace (Ocaml.vof_list vof_declaration_sequencable) v3 + in Ocaml.VSum (("ExternCList", [ v1; v2; v3 ]))*) + "" + | NameSpace ((v1, v2, v3)) -> + (*let v1 = vof_tok v1 + and v2 = vof_wrap2 Ocaml.vof_string v2 + and v3 = vof_brace (Ocaml.vof_list vof_declaration_sequencable) v3 + in Ocaml.VSum (("NameSpace", [ v1; v2; v3 ]))*) + "" + | NameSpaceExtend ((v1, v2)) -> + (*let v1 = Ocaml.vof_string v1 + and v2 = Ocaml.vof_list vof_declaration_sequencable v2 + in Ocaml.VSum (("NameSpaceExtend", [ v1; v2 ]))*) + "" + | NameSpaceAnon ((v1, v2)) -> + (*let v1 = vof_tok v1 + and v2 = vof_brace (Ocaml.vof_list vof_declaration_sequencable) v2 + in Ocaml.VSum (("NameSpaceAnon", [ v1; v2 ]))*) + "" + | EmptyDef def -> process_token def + | DeclTodo -> "# TODO" + +and process_fullType ((qualifier, typeC)) = + process_typeC typeC + +and process_toplevel = function + | NotParsedCorrectly node -> "" + | DeclElem node -> process_declaration node + | CppDirectiveDecl node -> process_cpp_directive node + | IfdefDecl node -> "" + | MacroTop ((v1, v2, v3)) -> "" + | MacroVarTop ((v1, v2)) -> "" + +let iter_ast ast = + List.map process_toplevel ast + +let test_dump_nim file = + Parse_cpp.init_defs !Flag.macros_h; + let ast = Parse_cpp.parse_program file in + let res = iter_ast ast in + List.iter pr res diff --git a/lang_cpp/parsing/test_dump_nim.mli b/lang_cpp/parsing/test_dump_nim.mli new file mode 100644 index 0000000..4bb2d5a --- /dev/null +++ b/lang_cpp/parsing/test_dump_nim.mli @@ -0,0 +1,2 @@ +val test_dump_nim : + Common.filename -> unit diff --git a/lang_cpp/parsing/test_parsing_cpp.ml b/lang_cpp/parsing/test_parsing_cpp.ml new file mode 100644 index 0000000..2ce914e --- /dev/null +++ b/lang_cpp/parsing/test_parsing_cpp.ml @@ -0,0 +1,115 @@ +open Common + +open Parse_info +open Ast_cpp +module Ast = Ast_cpp +module Flag = Flag_parsing_cpp +module TH = Token_helpers_cpp + +module Stat = Parse_info + +(*****************************************************************************) +(* Subsystem testing *) +(*****************************************************************************) + +let test_tokens_cpp file = + Flag.verbose_lexing := true; + Flag.verbose_parsing := true; + let toks = Parse_cpp.tokens file in + toks +> List.iter (fun x -> pr2_gen x); + () + +let test_dump_cpp file = + Parse_cpp.init_defs !Flag.macros_h; + let ast = Parse_cpp.parse_program file in + let v = Meta_ast_cpp.vof_program ast in + let s = Ocaml.string_of_v v in + pr s + + +let test_dump_cpp_full file = + Parse_cpp.init_defs !Flag.macros_h; + let ast = Parse_cpp.parse_program file in + let toks = Parse_cpp.tokens file in + let precision = { Meta_ast_generic. + full_info = true; type_info = true; token_info = true; + } + in + let v = Meta_ast_cpp.vof_program ~precision ast in + let s = Ocaml.string_of_v v in + pr s; + toks +> List.iter (fun tok -> + match tok with + | Parser_cpp.TComment (ii) -> + let v = Parse_info.vof_info ii in + let s = Ocaml.string_of_v v in + pr s + | _ -> () + ); + () + +let test_dump_cpp_view file = + Parse_cpp.init_defs !Flag.macros_h; + let toks_orig = Parse_cpp.tokens file in + let toks = + toks_orig +> Common.exclude (fun x -> + Token_helpers_cpp.is_comment x || + Token_helpers_cpp.is_eof x + ) + in + let extended = toks +> List.map Token_views_cpp.mk_token_extended in + Parsing_hacks_cpp.find_template_inf_sup extended; + + let multi = Token_views_cpp.mk_multi extended in + Token_views_context.set_context_tag_multi multi; + let v = Token_views_cpp.vof_multi_grouped_list multi in + let s = Ocaml.string_of_v v in + pr s + + +let test_parse_cpp_fuzzy xs = + let fullxs = Lib_parsing_cpp.find_source_files_of_dir_or_files xs + +> Skip_code.filter_files_if_skip_list + in + fullxs +> Console.progress (fun k -> List.iter (fun file -> + k (); + Common.save_excursion Flag_parsing_cpp.strict_lexer true (fun () -> + try + let _fuzzy = Parse_cpp.parse_fuzzy file in + () + with exn -> + pr2 (spf "PB with: %s, exn = %s" file (Common.exn_to_s exn)); + ) + )) + +let test_dump_cpp_fuzzy file = + let fuzzy, _toks = Parse_cpp.parse_fuzzy file in + let v = Ast_fuzzy.vof_trees fuzzy in + let s = Ocaml.string_of_v v in + pr2 s + +(*****************************************************************************) +(* Main entry for Arg *) +(*****************************************************************************) + +let actions () = [ + "-tokens_cpp", " ", + Common.mk_action_1_arg test_tokens_cpp; + + "-dump_cpp", " ", + Common.mk_action_1_arg test_dump_cpp; + + "-dump_nim", " ", + Common.mk_action_1_arg Test_dump_nim.test_dump_nim; + + "-dump_cpp_full", " ", + Common.mk_action_1_arg test_dump_cpp_full; + "-dump_cpp_view", " ", + Common.mk_action_1_arg test_dump_cpp_view; + + "-parse_cpp_fuzzy", " ", + Common.mk_action_n_arg test_parse_cpp_fuzzy; + "-dump_cpp_fuzzy", " ", + Common.mk_action_1_arg test_dump_cpp_fuzzy; + +] diff --git a/lang_cpp/parsing/test_parsing_cpp.mli b/lang_cpp/parsing/test_parsing_cpp.mli new file mode 100644 index 0000000..52e9fa5 --- /dev/null +++ b/lang_cpp/parsing/test_parsing_cpp.mli @@ -0,0 +1,12 @@ + +(* Print the set of tokens in a c++ file *) +val test_tokens_cpp : + Common.filename -> unit +val test_dump_cpp: + Common.filename -> unit + +(* This makes accessible the different test_xxx functions above from + * the command line, e.g. '$ pfff -parse_cpp foo.cpp will call the + * test_parse_cpp function. + *) +val actions : unit -> Common.cmdline_actions diff --git a/lang_cpp/parsing/todo_context b/lang_cpp/parsing/todo_context new file mode 100644 index 0000000..f76e579 --- /dev/null +++ b/lang_cpp/parsing/todo_context @@ -0,0 +1,144 @@ + +was in token_views_context.ml: + + + +(* +let look_like_only_idents xs = + xs +> List.for_all (function + | Tok {t=(TComma _ | TIdent _)} -> true + (* when have cast *) + | Parens _ -> true + | _ -> false + ) +*) + + + +(* + | BToken ({t=tokstruct; _})::BToken ({t= TIdent (s,_); _}) + ::Braceised(body, tok1, tok2)::xs when TH.is_classkey_keyword tokstruct -> + body +> List.iter (iter_token_brace (fun tok -> + tok.where <- (InClassStruct s)::tok.where; + )); + set_in_other xs + + (* struct/union/class x : ... { } *) + | BToken ({t= tokstruct; _})::BToken ({t=TIdent _; _}) + ::BToken ({t=TCol _})::xs when TH.is_classkey_keyword tokstruct -> + + (try + let (before, elem, after) = Common2.split_when is_braceised xs in + (match elem with + | Braceised(body, tok1, tok2) -> + body +> List.iter (iter_token_brace (fun tok -> + tok.where <- InInitializer::tok.where; + )); + set_in_other after + | _ -> raise Impossible + ) + with Not_found -> + pr2 ("PB: could not find braces after struct/union/class x : ..."); + ) + + *) + + + +(* todo: this lead to some regressions :( + (* = ... ; *) + | Tok ({t=TEq ii;where = [InTopLevel]})::xs -> + + let (before, ptvirg, after) = + try + xs +> Common2.split_when (function + | Tok ({t=TPtVirg _;}) -> true + | _ -> false + ) + with Not_found -> + raise (UnclosedSymbol (spf "PB with split_when at %s" + (Parse_info.string_of_info ii))) + in + before +> TV.iter_token_multi (fun tok -> + tok.TV.where <- TV.InAssign::tok.TV.where; + ); + aux before; + aux [ptvirg]; + aux after +*) + + (* TODO xx(...) { InFunction (can have some try or const or throw after + * the paren *) + + (* could try: ) { } but it can be the ) of a if or while, so + * better to base the heuristic on the position in column zero. + * Note that some struct or enum or init put also their { in first column + * but set_in_other will overwrite the previous InFunction tag. + *) + +(*TODOC++ext: now can have some const or throw between + => do a view that filter them first ? +*) + +(* + + (* ) { and the closing } is in column zero, then certainly a function *) +(*TODO1 col 0 not valid anymore with c++ nestedness of method *) + | BToken ({t=TCPar _})::(Braceised (body, tok1, Some tok2))::xs + when tok1.col <> 0 && tok2.col = 0 -> + body +> List.iter (iter_token_brace (fun tok -> + tok.where <- InFunction::tok.where; + )); + aux xs + + | (BToken x)::xs -> aux xs + +(*TODO1 not valid anymore with c++ nestedness of method *) + | (Braceised (body, tok1, Some tok2))::xs + when tok1.col = 0 && tok2.col = 0 -> + body +> List.iter (iter_token_brace (fun tok -> + tok.where <- InFunction::tok.where; + )); + aux xs + | Braceised (body, tok1, tok2)::xs -> + aux xs + in + + + (* TODO <...> InTemplateParam *) + *) + + + + + + + + (* C++: second tentative on InArgument, if xx(xx, yy, ww) where have only + * identifiers, it's probably a constructed object! + * But FP on C code, so should guard that with Flag_parsing_cpp.lang = C++ + *) +(* + | Tok{t=TIdent _; where = ctx}::(Parens(_t1, body, _t2) as parens)::xs + when List.length body > 0 && look_like_only_idents body -> + [parens] +> TV.iter_token_multi (fun tok -> + let where = + match ctx with + | TV.InTopLevel::_ -> TV.InParameter + | TV.InAssign::_ -> TV.InArgument + | _ -> TV.InArgument + in + tok.TV.where <- where::tok.TV.where; + ); + (* todo? recurse on body? *) + aux (parens::xs) + + (* could be a cast too ... or what else? *) + | x::(Parens(_t1, _body, _t2) as parens)::xs -> + (* let's default to something? hmm, no, got lots of regressions then + * old: msg_context t1.t (TV.InArgument); ... + *) + aux [x]; + aux (parens::xs) +*) + diff --git a/lang_cpp/parsing/todo_ml b/lang_cpp/parsing/todo_ml new file mode 100644 index 0000000..c6773cd --- /dev/null +++ b/lang_cpp/parsing/todo_ml @@ -0,0 +1,164 @@ + +let noInstr = (ExprStatement (None), []) + +(*****************************************************************************) +(* Wrappers *) +(*****************************************************************************) + +let unwrap_expr ((unwrap_e, typ), iie) = unwrap_e +let rewrap_expr ((_old_unwrap_e, typ), iie) newe = ((newe, typ), iie) + +let get_type_expr ((unwrap_e, typ), iie) = !typ +let set_type_expr ((unwrap_e, oldtyp), iie) newtyp = + oldtyp := newtyp + (* old: (unwrap_e, newtyp), iie *) + +let unwrap_typeC (qu, (typeC, ii)) = typeC +let rewrap_typeC (qu, (typeC, ii)) newtypeC = (qu, (newtypeC, ii)) + + +let is_fake ii = + match ii.pinfo with + FakeTok (_,_) -> true + | _ -> false + + + +let mcode_of_info ii = fst (!(ii.cocci_tag)) + +type posrv = Real of Common.parse_info | Virt of virtual_position +let compare_pos ii1 ii2 = + let get_pos = function + OriginTok pi -> Real pi + | FakeTok (s,vpi) -> Virt vpi + | ExpandedTok (pi,vpi) -> Virt vpi + | AbstractLineTok pi -> Real pi in (* used for printing *) + let pos1 = get_pos (pinfo_of_info ii1) in + let pos2 = get_pos (pinfo_of_info ii2) in + match (pos1,pos2) with + (Real p1, Real p2) -> compare p1.Common.charpos p2.Common.charpos + | (Virt (p1,_), Real p2) -> + if (compare p1.Common.charpos p2.Common.charpos) = (-1) then (-1) else 1 + | (Real p1, Virt (p2,_)) -> + if (compare p1.Common.charpos p2.Common.charpos) = 1 then 1 else (-1) + | (Virt (p1,o1), Virt (p2,o2)) -> + let poi1 = p1.Common.charpos in + let poi2 = p2.Common.charpos in + match compare poi1 poi2 with + -1 -> -1 + | 0 -> compare o1 o2 + | x -> x + +let equal_posl (l1,c1) (l2,c2) = + (l1 =|= l2) && (c1 =|= c2) + +let info_to_fixpos ii = + match pinfo_of_info ii with + OriginTok pi -> Ast_cocci.Real pi.Common.charpos + | ExpandedTok (_,(pi,offset)) -> + Ast_cocci.Virt (pi.Common.charpos,offset) + | FakeTok (_,(pi,offset)) -> + Ast_cocci.Virt (pi.Common.charpos,offset) + | AbstractLineTok pi -> failwith "unexpected abstract" + + +(*****************************************************************************) +(* Abstract line *) +(*****************************************************************************) + +(* When we have extended the C Ast to add some info to the tokens, + * such as its line number in the file, we can not use anymore the + * ocaml '=' to compare Ast elements. To overcome this problem, to be + * able to use again '=', we just have to get rid of all those extra + * information, to "abstract those line" (al) information. + *) + +let al_info tokenindex x = + { pinfo = + (AbstractLineTok + {charpos = tokenindex; + line = tokenindex; + column = tokenindex; + file = ""; + str = str_of_info x}); + cocci_tag = ref emptyAnnot; + comments_tag = ref emptyComments; + } + +let semi_al_info x = + { x with + cocci_tag = ref emptyAnnot; + comments_tag = ref emptyComments; + } + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +(* todo? could also stringify the all ident? *) +let string_of_name name = + let (_qtop, _scope, (ident, _ii)) = name in + match ident with + | IdIdent s -> s + | IdOperator op -> "op todo" + | IdConverter ft -> "converter todo" + | IdDestructor xx -> "destructor todo" + | IdTemplateId (s, args) -> "template todo" + +let is_simple_ident name = + let (qtop, scope, (ident, _ii)) = name in + match qtop, scope, ident with + | None, [], IdIdent _ -> true + | _ -> false + +(* good to look at su ? some people use class for struct too ? *) +let is_class_structunion class_def = + let (su, _sopt, _bopt, (members: class_member_sequencable list)),_ii = class_def in + su = Class || + (members +> List.exists (fun x -> + match x with + | ClassElem (DeclarationField _,ii) -> false + | ClassElem (EmptyField, ii) -> false + | _ -> true + )) + + +(*****************************************************************************) +(* Views *) +(*****************************************************************************) + +(* Transform a list of arguments (or parameters) where the commas are + * represented via the wrap2 and associated with an element, with + * a list where the comma are on their own. f(1,2,2) was + * [(1,[]); (2,[,]); (2,[,])] and become [1;',';2;',';2]. + * + * Used in cocci_vs_c.ml, to have a more direct correspondance between + * the ast_cocci of julia and ast_c. + *) +let rec (split_comma: 'a wrap2 list -> ('a, il) either list) = + function + | [] -> [] + | (e, ii)::xs -> + if null ii + then (Left e)::split_comma xs + else Right ii::Left e::split_comma xs + +let rec (unsplit_comma: ('a, il) either list -> 'a wrap2 list) = + function + | [] -> [] + | Right ii::Left e::xs -> + (e, ii)::unsplit_comma xs + | Left e::xs -> + let empty_ii = [] in + (e, empty_ii)::unsplit_comma xs + | Right ii::_ -> + raise Impossible + + +let split_register_param = fun (hasreg, idb, ii_b_s) -> + match hasreg, idb, ii_b_s with + | false, Some s, [i1] -> Left (s, [], i1) + | true, Some s, [i1;i2] -> Left (s, [i1], i2) + | _, None, ii -> Right ii + | _ -> raise Impossible + diff --git a/lang_cpp/parsing/todo_mly b/lang_cpp/parsing/todo_mly new file mode 100644 index 0000000..41543b7 --- /dev/null +++ b/lang_cpp/parsing/todo_mly @@ -0,0 +1,48 @@ + +%token +/*(* TTilde2? *)*/ +/*(* Tunsigned Tsigned Tvoid *)*/ + + + + +statement: + + /*(* c++ext: TODO put at good place later *)*/ + | Tswitch TOPar decl_spec init_declarator_list TCPar statement + { StmtTodo, noii } + + | Tif TOPar decl_spec init_declarator_list TCPar statement %prec LOW_PRIORITY_RULE + { StmtTodo, noii } + | Tif TOPar decl_spec init_declarator_list TCPar statement Telse statement + { StmtTodo, noii } + + /*(* c++ext: for(int i = 0; i < n; i++)*)*/ + | Tfor TOPar simple_declaration expr_statement expr_opt TCPar statement + { StmtTodo, noii } + + + + +argument: + +/* TODO: reenable, put in comment while trying to parse plan9 + | action_higherordermacro { Right (ArgAction $1) } + +action_higherordermacro: + | taction_list + { if null $1 + then ActMisc [Ast_cpp.fakeInfo()] + else ActMisc $1 + } +*/ + + +/* toreput, was especially used for the Linux kernel +taction_list: + (* c++ext: to remove some conflicts (from 13 to 4) + * | (* empty *) { [] } + *) + | TAny_Action { [$1] } + | taction_list TAny_Action { $1 @ [$2] } +*/ diff --git a/lang_cpp/parsing/token_cpp.ml b/lang_cpp/parsing/token_cpp.ml new file mode 100644 index 0000000..1e486a6 --- /dev/null +++ b/lang_cpp/parsing/token_cpp.ml @@ -0,0 +1,73 @@ +(* Yoann Padioleau + * + * Copyright (C) 2009 University of Urbana Champaign + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * This file may seem redundant with the tokens generated by Yacc + * from parser.mly in parser_c.mli. The problem is that we need for + * many reasons to remember in the AST the tokens involved in the + * AST, not just the string, especially for the comment and cpp_passed + * tokens which are not in the AST at all. So, + * to avoid recursive mutual dependencies, we provide this file + * so that Ast_cpp does not need to depend on yacc which depends on + * Ast_cpp, etc. + * + * Also, ocamlyacc imposes some stupid constraints on the way we can define + * the token type. ocamlyacc forces us to do a token type that + * cant be a pair of a sum type, it must be directly a sum type. + * We don't have this constraint here. + * + * Also, some yacc tokens are not used in the grammar because they are filtered + * in some intermediate phases. But they still must be declared because + * ocamllex may generate them, or some intermediate phase may also + * generate them (like some functions in parsing_hacks.ml). + * Here we don't have this problem again so we can have a clearer token type. + * + *) + +(*****************************************************************************) +(* constructs put in comments in lexer or parsing_hack *) +(*****************************************************************************) + +(* + * history: was in ast_cpp.ml before: + * "This type is not in the Ast but is associated with the TCommentCpp + * token. I put this enum here because parser_c.mly needs it. I could + * have put it also in lexer_parser." + * + * update: now in token_cpp.ml, and actually right now we want those tokens + * to be in the AST so that in the matching/transforming of C code, we + * can detect if some metavariables match code which have some + * cpp_passed tokens next to them (and so where we should issue a warning). + *) +type cppcommentkind = + | CppDirective + | CppAttr + | CppMacro + | CppMacroExpanded + | CppPassingNormal (* ifdef 0, cplusplus, etc *) + | CppPassingCosWouldGetError (* expr passsing *) +(* TODO | CppPassingExplicit (* skip_start/end tag *) instead of CppOther? *) + | CppOther + +(* at some point we are supposed to also parse those constructs *) +type cpluspluscommentkind = + | CplusplusTemplate + | CplusplusQualifier + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) diff --git a/lang_cpp/parsing/token_cpp.mli b/lang_cpp/parsing/token_cpp.mli new file mode 100644 index 0000000..5a21b27 --- /dev/null +++ b/lang_cpp/parsing/token_cpp.mli @@ -0,0 +1,13 @@ + +type cppcommentkind = + | CppDirective + | CppAttr + | CppMacro + | CppMacroExpanded + | CppPassingNormal (* ifdef 0, cplusplus, etc *) + | CppPassingCosWouldGetError (* expr passsing *) + | CppOther + +type cpluspluscommentkind = + | CplusplusTemplate + | CplusplusQualifier diff --git a/lang_cpp/parsing/token_helpers_cpp.ml b/lang_cpp/parsing/token_helpers_cpp.ml new file mode 100644 index 0000000..0862525 --- /dev/null +++ b/lang_cpp/parsing/token_helpers_cpp.ml @@ -0,0 +1,730 @@ + +(* tokens *) +open Parser_cpp +module PI = Parse_info + +(*****************************************************************************) +(* Is_xxx, categories *) +(*****************************************************************************) + +let is_eof = function + | EOF _ -> true + | _ -> false + +(* ---------------------------------------------------------------------- *) +let is_space = function + | TCommentSpace _ | TCommentNewline _ -> true + | _ -> false + +let is_comment_or_space = function + | TCommentSpace _ | TCommentNewline _ + | TComment _ + -> true + | _ -> false + +let is_just_comment = function + | TComment _ -> true + | _ -> false + +let is_comment = function + | TCommentSpace _ | TCommentNewline _ + | TComment _ + | TComment_Pp _ | TComment_Cpp _ + -> true + | _ -> false + +let is_real_comment = function + | TComment _ | TCommentSpace _ + | TCommentNewline _ + -> true + | _ -> false + +let is_fake_comment = function + | TComment_Pp _ | TComment_Cpp _ -> true + | _ -> false + +let is_not_comment x = + not (is_comment x) + +(* ---------------------------------------------------------------------- *) +(* +let is_gcc_token = function + | Tasm _ | Tinline _ | Tattribute _ | Ttypeof _ + -> true + | _ -> false +*) + +let is_pp_instruction = function + | TInclude _ + | TDefine _ + | TIfdef _ | TIfdefelse _ | TIfdefelif _ + | TEndif _ + | TIfdefBool _ | TIfdefMisc _ | TIfdefVersion _ + | TUndef _ + | TCppDirectiveOther _ + -> true + | _ -> false + + +let is_opar = function + | TOPar _ | TOPar_Define _ | TOPar_CplusplusInit _ -> true + | _ -> false + +let is_cpar = function + | TCPar _ | TCPar_EOL _ -> true + | _ -> false + +let is_obrace = function + | TOBrace _ | TOBrace_DefineInit _ -> true + | _ -> false + +let is_cbrace = function + | TCBrace _ -> true + | _ -> false + + +let is_statement = function + | Tfor _ | Tdo _ | Tif _ | Twhile _ | Treturn _ + | Tbreak _ | Telse _ | Tswitch _ | Tcase _ | Tcontinue _ + | Tgoto _ + | TPtVirg _ + | TIdent_MacroIterator _ + -> true + | _ -> false + +(* is_start_of_something is used in parse_c for error recovery, to find + * a synchronisation token. + * + * Would like to put TIdent or TDefine, TIfdef but they can be in the + * middle of a function, for instance with label:. + * + * Could put Typedefident but fired ? it would work in error recovery + * on the already_passed tokens, which has been already gone in the + * Parsing_hacks.lookahead machinery, but it will not work on the + * "next" tokens. But because the namespace for labels is different + * from namespace for ident/typedef, we can use the name for a typedef + * for a label and so dangerous to put Typedefident at true here. + * + * Can look in parser_c.output to know what can be at toplevel + * at the very beginning. + *) + +let is_start_of_something = function + | Tchar _ | Tshort _ | Tint _ | Tdouble _ | Tfloat _ | Tlong _ + | Tunsigned _ | Tsigned _ | Tvoid _ + | Tauto _ | Tregister _ | Textern _ | Tstatic _ + | Tconst _ | Tvolatile _ + | Ttypedef _ + | Tstruct _ | Tunion _ | Tenum _ + (* c++ext: *) + | Tclass _ + | Tbool _ + | Twchar_t _ + -> true + | _ -> false + + +let is_binary_operator = function + | TOrLog _ | TAndLog _ | TOr _ | TXor _ | TAnd _ + | TEqEq _ | TNotEq _ | TInf _ | TSup _ | TInfEq _ | TSupEq _ + | TShl _ | TShr _ + | TPlus _ | TMinus _ | TMul _ | TDiv _ | TMod _ + -> true + | _ -> false + +let is_binary_operator_except_star = function + (* | TAnd _ *) (*| TMul _*) + | TOrLog _ | TAndLog _ | TOr _ | TXor _ + | TEqEq _ | TNotEq _ | TInf _ | TSup _ | TInfEq _ | TSupEq _ + | TShl _ | TShr _ + | TPlus _ | TMinus _ | TDiv _ | TMod _ + -> true + | _ -> false + +let is_stuff_taking_parenthized = function + | Tif _ + | Twhile _ + | Tswitch _ + | Ttypeof _ + | TIdent_MacroIterator _ + -> true + | _ -> false + +let is_static_cast_like = function + | Tconst_cast _ | Tdynamic_cast _ | Tstatic_cast _ | Treinterpret_cast _ -> + true + | _ -> false + +let is_basic_type = function + | Tchar _ | Tshort _ | Tint _ | Tdouble _ | Tfloat _ | Tlong _ + | Tbool _ | Twchar_t _ + | Tunsigned _ | Tsigned _ + | Tvoid _ + -> true + | _ -> false + + +let is_struct_like_keyword = function + | (Tstruct _ | Tunion _ | Tenum _) -> true + (* c++ext: *) + | (Tclass _) -> true + | _ -> false + +let is_classkey_keyword = function + | (Tstruct _ | Tunion _ | Tclass _) -> true + | _ -> false + +let is_cpp_keyword = function + | Tclass _ | Tthis _ + + | Tnew _ + | Tdelete _ + + | Ttemplate _ | Ttypeid _ | Ttypename _ + + | Tcatch _ | Ttry _ | Tthrow _ + + | Toperator _ + | Tpublic _ | Tprivate _ | Tprotected _ + + | Tfriend _ + + | Tvirtual _ + + | Tnamespace _ | Tusing _ + + | Tbool _ + | Tfalse _ | Ttrue _ + + | Twchar_t _ + | Tconst_cast _ | Tdynamic_cast _ | Tstatic_cast _ | Treinterpret_cast _ + | Texplicit _ + | Tmutable _ + + | Texport _ + -> true + + | _ -> false + +let is_really_cpp_keyword = function + | Tconst_cast _ | Tdynamic_cast _ | Tstatic_cast _ | Treinterpret_cast _ + -> true +(* when have some asm volatile, can have some :: + | TColCol _ + -> true +*) + | _ -> false + +(* some false positive on some C file like sqlite3.c *) +let is_maybenot_cpp_keyword = function + | Tpublic _ | Tprivate _ | Tprotected _ + | Ttemplate _ | Tnew _ | Ttypename _ + | Tnamespace _ + -> true + | _ -> false + + +(* used in the algorithm for "10 most problematic tokens". C-s for TIdent + * in parser_cpp.mly + *) +let is_ident_like = function + | TIdent _ + | TIdent_Typedef _ + | TIdent_Define _ +(* | TDefParamVariadic _*) + + | TUnknown _ + + | TIdent_MacroStmt _ + | TIdent_MacroString _ + | TIdent_MacroIterator _ + | TIdent_MacroDecl _ +(* | TIdent_MacroDeclConst _ *) +(* + | TIdent_MacroAttr _ + | TIdent_MacroAttrStorage _ +*) + + | TIdent_ClassnameInQualifier _ + | TIdent_ClassnameInQualifier_BeforeTypedef _ + | TIdent_Templatename _ + | TIdent_TemplatenameInQualifier _ + | TIdent_TemplatenameInQualifier_BeforeTypedef _ + | TIdent_Constructor _ + | TIdent_TypedefConstr _ + -> true + + | _ -> false + +let is_privacy_keyword = function + | Tpublic _ | Tprivate _ | Tprotected _ + -> true + | _ -> false + + +let token_kind_of_tok t = + match t with + (* todo: ( ) { } ... *) + + | TComment _ | TComment_Pp _ | TComment_Cpp _ -> PI.Esthet PI.Comment + | TCommentSpace _ -> PI.Esthet PI.Space + | TCommentNewline _ -> PI.Esthet PI.Newline + + | _ -> PI.Other + +(*****************************************************************************) +(* Visitors *) +(*****************************************************************************) + +(* Because ocamlyacc force us to do it that way. The ocamlyacc token + * cant be a pair of a sum type, it must be directly a sum type. + *) +let info_of_tok = function + | TString ((_s, _isWchar), i) -> i + | TChar ((_s, _isWchar), i) -> i + | TFloat ((_s, _floatType), i) -> i + + | TAssign (_assignOp, i) -> i + + | TIdent (_s, i) -> i + | TIdent_Typedef (_s, i) -> i + + | TInt (_s, i) -> i + + (*cppext:*) + | TDefine (ii) -> ii + | TInclude (_includes, _filename, i1) -> i1 + + | TUndef (_s, ii) -> ii + | TCppDirectiveOther (ii) -> ii + + | TCommentNewline_DefineEndOfMacro (i1) -> i1 + | TOPar_Define (i1) -> i1 + | TIdent_Define (_s, i) -> i + | TOBrace_DefineInit (i1) -> i1 + + | TCppEscapedNewline (ii) -> ii + | TDefParamVariadic (_s, i1) -> i1 + + + | TUnknown (i) -> i + + | TIdent_MacroStmt (i) -> i + | TIdent_MacroString (i) -> i + | TIdent_MacroIterator (_s,i) -> i + | TIdent_MacroDecl (_s, i) -> i + | Tconst_MacroDeclConst (i) -> i +(* | TMacroTop (_s,i) -> i *) + | TCPar_EOL (i1) -> i1 + + | TAny_Action (i) -> i + + | TComment (i) -> i + | TCommentSpace (i) -> i + | TComment_Pp (_cppkind, i) -> i + | TComment_Cpp (_cppkind, i) -> i + | TCommentNewline (i) -> i + + | TIfdef (i) -> i + | TIfdefelse (i) -> i + | TIfdefelif (i) -> i + | TEndif (i) -> i + | TIfdefBool (_b, i) -> i + | TIfdefMisc (_b, i) -> i + | TIfdefVersion (_b, i) -> i + + | TOPar (i) -> i + | TOPar_CplusplusInit (i) -> i + | TCPar (i) -> i + | TOBrace (i) -> i + | TCBrace (i) -> i + | TOCro (i) -> i + | TCCro (i) -> i + | TDot (i) -> i + | TComma (i) -> i + | TPtrOp (i) -> i + | TInc (i) -> i + | TDec (i) -> i + | TEq (i) -> i + | TWhy (i) -> i + | TTilde (i) -> i + | TBang (i) -> i + | TEllipsis (i) -> i + | TCol (i) -> i + | TPtVirg (i) -> i + | TOrLog (i) -> i + | TAndLog (i) -> i + | TOr (i) -> i + | TXor (i) -> i + | TAnd (i) -> i + | TEqEq (i) -> i + | TNotEq (i) -> i + | TInf (i) -> i + | TSup (i) -> i + | TInfEq (i) -> i + | TSupEq (i) -> i + | TShl (i) -> i + | TShr (i) -> i + | TPlus (i) -> i + | TMinus (i) -> i + | TMul (i) -> i + | TDiv (i) -> i + | TMod (i) -> i + + | Tchar (i) -> i + | Tshort (i) -> i + | Tint (i) -> i + | Tdouble (i) -> i + | Tfloat (i) -> i + | Tlong (i) -> i + | Tunsigned (i) -> i + | Tsigned (i) -> i + | Tvoid (i) -> i + | Tauto (i) -> i + | Tregister (i) -> i + | Textern (i) -> i + | Tstatic (i) -> i + | Tconst (i) -> i + | Tvolatile (i) -> i + + | Trestrict (i) -> i + + | Tstruct (i) -> i + | Tenum (i) -> i + | Ttypedef (i) -> i + | Tunion (i) -> i + | Tbreak (i) -> i + | Telse (i) -> i + | Tswitch (i) -> i + | Tcase (i) -> i + | Tcontinue (i) -> i + | Tfor (i) -> i + | Tdo (i) -> i + | Tif (i) -> i + | Twhile (i) -> i + | Treturn (i) -> i + | Tgoto (i) -> i + | Tdefault (i) -> i + | Tsizeof (i) -> i + + (* gccext: *) + | Tasm (i) -> i + | Tattribute (i) -> i + | Tinline (i) -> i + | Ttypeof (i) -> i + + (* c++ext: *) + | Tclass (i) -> i + | Tthis (i) -> i + + | Tnew (i) -> i + | Tdelete (i) -> i + + | Ttemplate (i) -> i + | Ttypeid (i) -> i + | Ttypename (i) -> i + + | Tcatch (i) -> i + | Ttry (i) -> i + | Tthrow (i) -> i + + | Toperator (i) -> i + + | Tpublic (i) -> i + | Tprivate (i) -> i + | Tprotected (i) -> i + | Tfriend (i) -> i + + | Tvirtual (i) -> i + + | Tnamespace (i) -> i + | Tusing (i) -> i + + | Tbool (i) -> i + | Ttrue (i) -> i + | Tfalse (i) -> i + + | Twchar_t (i) -> i + + | Tconst_cast (i) -> i + | Tdynamic_cast (i) -> i + | Tstatic_cast (i) -> i + | Treinterpret_cast (i) -> i + + | Texplicit (i) -> i + | Tmutable (i) -> i + | Texport (i) -> i + + | TColCol (i) -> i + | TColCol_BeforeTypedef (i) -> i + + | TPtrOpStar (i) -> i + | TDotStar(i) -> i + + | TIdent_ClassnameInQualifier (_s, i) -> i + | TIdent_ClassnameInQualifier_BeforeTypedef (_s, i) -> i + | TIdent_Templatename (_s, i) -> i + | TIdent_Constructor (_s, i) -> i + | TIdent_TypedefConstr (_s, i) -> i + | TIdent_TemplatenameInQualifier (_s, i) -> i + | TIdent_TemplatenameInQualifier_BeforeTypedef (_s, i) -> i + + | TInf_Template (i) -> i + | TSup_Template (i) -> i + + | TOCro_new (i) -> i + | TCCro_new (i) -> i + + | TInt_ZeroVirtual (i) -> i + + | Tchar_Constr (i) -> i + | Tint_Constr (i) -> i + | Tfloat_Constr (i) -> i + | Tdouble_Constr (i) -> i + | Twchar_t_Constr (i) -> i + + | Tshort_Constr (i) -> i + | Tlong_Constr (i) -> i + | Tbool_Constr (i) -> i + + | Tunsigned_Constr i -> i + | Tsigned_Constr i -> i + + | EOF (i) -> i + + + +(* used by tokens to complete the parse_info with filename, line, col infos *) +let visitor_info_of_tok f = function + | TString ((s, isWchar), i) -> TString ((s, isWchar), f i) + | TChar ((s, isWchar), i) -> TChar ((s, isWchar), f i) + | TFloat ((s, floatType), i) -> TFloat ((s, floatType), f i) + | TAssign (assignOp, i) -> TAssign (assignOp, f i) + + | TIdent (s, i) -> TIdent (s, f i) + | TIdent_Typedef (s, i) -> TIdent_Typedef (s, f i) + + | TInt (s, i) -> TInt (s, f i) + + (* cppext: *) + | TDefine (i1) -> TDefine(f i1) + + | TUndef (s,i1) -> TUndef(s, f i1) + | TCppDirectiveOther (i1) -> TCppDirectiveOther(f i1) + + | TInclude (includes, filename, i1) -> + TInclude (includes, filename, f i1) + + | TCppEscapedNewline (i1) -> TCppEscapedNewline (f i1) + | TCommentNewline_DefineEndOfMacro (i1) -> + TCommentNewline_DefineEndOfMacro (f i1) + | TOPar_Define (i1) -> TOPar_Define (f i1) + | TIdent_Define (s, i) -> TIdent_Define (s, f i) + + | TDefParamVariadic (s, i1) -> TDefParamVariadic (s, f i1) + + | TOBrace_DefineInit (i1) -> TOBrace_DefineInit (f i1) + + + | TUnknown (i) -> TUnknown (f i) + + | TIdent_MacroStmt (i) -> TIdent_MacroStmt (f i) + | TIdent_MacroString (i) -> TIdent_MacroString (f i) + | TIdent_MacroIterator (s,i) -> TIdent_MacroIterator (s,f i) + | TIdent_MacroDecl (s,i) -> TIdent_MacroDecl (s, f i) + | Tconst_MacroDeclConst (i) -> Tconst_MacroDeclConst (f i) +(* | TMacroTop (s,i) -> TMacroTop (s,f i) *) + | TCPar_EOL (i) -> TCPar_EOL (f i) + + + | TAny_Action (i) -> TAny_Action (f i) + + | TComment (i) -> TComment (f i) + | TCommentSpace (i) -> TCommentSpace (f i) + | TCommentNewline (i) -> TCommentNewline (f i) + + | TComment_Pp (cppkind, i) -> TComment_Pp (cppkind, f i) + | TComment_Cpp (cppkind, i) -> TComment_Cpp (cppkind, f i) + + | TIfdef (i) -> TIfdef (f i) + | TIfdefelse (i) -> TIfdefelse (f i) + | TIfdefelif (i) -> TIfdefelif (f i) + | TEndif (i) -> TEndif (f i) + | TIfdefBool (b, i) -> TIfdefBool (b, f i) + | TIfdefMisc (b, i) -> TIfdefMisc (b, f i) + | TIfdefVersion (b, i) -> TIfdefVersion (b, f i) + + | TOPar (i) -> TOPar (f i) + | TOPar_CplusplusInit (i) -> TOPar_CplusplusInit (f i) + | TCPar (i) -> TCPar (f i) + | TOBrace (i) -> TOBrace (f i) + | TCBrace (i) -> TCBrace (f i) + | TOCro (i) -> TOCro (f i) + | TCCro (i) -> TCCro (f i) + | TDot (i) -> TDot (f i) + | TComma (i) -> TComma (f i) + | TPtrOp (i) -> TPtrOp (f i) + | TInc (i) -> TInc (f i) + | TDec (i) -> TDec (f i) + | TEq (i) -> TEq (f i) + | TWhy (i) -> TWhy (f i) + | TTilde (i) -> TTilde (f i) + | TBang (i) -> TBang (f i) + | TEllipsis (i) -> TEllipsis (f i) + | TCol (i) -> TCol (f i) + | TPtVirg (i) -> TPtVirg (f i) + | TOrLog (i) -> TOrLog (f i) + | TAndLog (i) -> TAndLog (f i) + | TOr (i) -> TOr (f i) + | TXor (i) -> TXor (f i) + | TAnd (i) -> TAnd (f i) + | TEqEq (i) -> TEqEq (f i) + | TNotEq (i) -> TNotEq (f i) + | TInf (i) -> TInf (f i) + | TSup (i) -> TSup (f i) + | TInfEq (i) -> TInfEq (f i) + | TSupEq (i) -> TSupEq (f i) + | TShl (i) -> TShl (f i) + | TShr (i) -> TShr (f i) + | TPlus (i) -> TPlus (f i) + | TMinus (i) -> TMinus (f i) + | TMul (i) -> TMul (f i) + | TDiv (i) -> TDiv (f i) + | TMod (i) -> TMod (f i) + | Tchar (i) -> Tchar (f i) + | Tshort (i) -> Tshort (f i) + | Tint (i) -> Tint (f i) + | Tdouble (i) -> Tdouble (f i) + | Tfloat (i) -> Tfloat (f i) + | Tlong (i) -> Tlong (f i) + | Tunsigned (i) -> Tunsigned (f i) + | Tsigned (i) -> Tsigned (f i) + | Tvoid (i) -> Tvoid (f i) + | Tauto (i) -> Tauto (f i) + | Tregister (i) -> Tregister (f i) + | Textern (i) -> Textern (f i) + | Tstatic (i) -> Tstatic (f i) + | Tconst (i) -> Tconst (f i) + | Tvolatile (i) -> Tvolatile (f i) + + | Trestrict (i) -> Trestrict (f i) + + + | Tstruct (i) -> Tstruct (f i) + | Tenum (i) -> Tenum (f i) + | Ttypedef (i) -> Ttypedef (f i) + | Tunion (i) -> Tunion (f i) + | Tbreak (i) -> Tbreak (f i) + | Telse (i) -> Telse (f i) + | Tswitch (i) -> Tswitch (f i) + | Tcase (i) -> Tcase (f i) + | Tcontinue (i) -> Tcontinue (f i) + | Tfor (i) -> Tfor (f i) + | Tdo (i) -> Tdo (f i) + | Tif (i) -> Tif (f i) + | Twhile (i) -> Twhile (f i) + | Treturn (i) -> Treturn (f i) + | Tgoto (i) -> Tgoto (f i) + | Tdefault (i) -> Tdefault (f i) + | Tsizeof (i) -> Tsizeof (f i) + | Tasm (i) -> Tasm (f i) + | Tattribute (i) -> Tattribute (f i) + | Tinline (i) -> Tinline (f i) + | Ttypeof (i) -> Ttypeof (f i) + + + | Tclass (i) -> Tclass (f i) + | Tthis (i) -> Tthis (f i) + + | Tnew (i) -> Tnew (f i) + | Tdelete (i) -> Tdelete (f i) + + | Ttemplate (i) -> Ttemplate (f i) + | Ttypeid (i) -> Ttypeid (f i) + | Ttypename (i) -> Ttypename (f i) + + | Tcatch (i) -> Tcatch (f i) + | Ttry (i) -> Ttry (f i) + | Tthrow (i) -> Tthrow (f i) + + | Toperator (i) -> Toperator (f i) + + | Tpublic (i) -> Tpublic (f i) + | Tprivate (i) -> Tprivate (f i) + | Tprotected (i) -> Tprotected (f i) + | Tfriend (i) -> Tfriend (f i) + + | Tvirtual (i) -> Tvirtual (f i) + + | Tnamespace (i) -> Tnamespace (f i) + | Tusing (i) -> Tusing (f i) + + | Tbool (i) -> Tbool (f i) + | Ttrue (i) -> Ttrue (f i) + | Tfalse (i) -> Tfalse (f i) + + | Twchar_t (i) -> Twchar_t (f i) + + | Tconst_cast (i) -> Tconst_cast (f i) + | Tdynamic_cast (i) -> Tdynamic_cast (f i) + | Tstatic_cast (i) -> Tstatic_cast (f i) + | Treinterpret_cast (i) -> Treinterpret_cast (f i) + + | Texplicit (i) -> Texplicit (f i) + | Tmutable (i) -> Tmutable (f i) + + | Texport (i) -> Texport (f i) + + + + | TColCol (i) -> TColCol (f i) + | TColCol_BeforeTypedef (i) -> TColCol_BeforeTypedef (f i) + + | TPtrOpStar (i) -> TPtrOpStar (f i) + | TDotStar(i) -> TDotStar (f i) + + + | TIdent_ClassnameInQualifier (s, i) -> TIdent_ClassnameInQualifier (s, f i) + | TIdent_ClassnameInQualifier_BeforeTypedef (s, i) -> + TIdent_ClassnameInQualifier_BeforeTypedef (s, f i) + | TIdent_Templatename (s, i) -> TIdent_Templatename (s, f i) + | TIdent_Constructor (s, i) -> TIdent_Constructor (s, f i) + | TIdent_TypedefConstr (s, i) -> TIdent_TypedefConstr (s, f i) + + | TIdent_TemplatenameInQualifier (s, i) -> + TIdent_TemplatenameInQualifier (s, f i) + | TIdent_TemplatenameInQualifier_BeforeTypedef (s, i) -> + TIdent_TemplatenameInQualifier_BeforeTypedef (s, f i) + + | TInf_Template (i) -> TInf_Template (f i) + | TSup_Template (i) -> TSup_Template (f i) + + | TOCro_new (i) -> TOCro_new (f i) + | TCCro_new (i) -> TCCro_new (f i) + + + | TInt_ZeroVirtual (i) -> TInt_ZeroVirtual (f i) + + | Tchar_Constr (i) -> Tchar_Constr (f i) + | Tint_Constr (i) -> Tint_Constr (f i) + | Tfloat_Constr (i) -> Tfloat_Constr (f i) + | Tdouble_Constr (i) -> Tdouble_Constr (f i) + | Twchar_t_Constr (i) -> Twchar_t_Constr (f i) + + | Tshort_Constr (i) -> Tshort_Constr (f i) + | Tlong_Constr (i) -> Tlong_Constr (f i) + | Tbool_Constr (i) -> Tbool_Constr (f i) + + | Tsigned_Constr (i) -> Tsigned_Constr (f i) + | Tunsigned_Constr (i) -> Tunsigned_Constr (f i) + + | EOF (i) -> EOF (f i) + + +(*****************************************************************************) +(* Accessors *) +(*****************************************************************************) + +let line_of_tok tok = + let info = info_of_tok tok in + PI.line_of_info info diff --git a/lang_cpp/parsing/token_helpers_cpp.mli b/lang_cpp/parsing/token_helpers_cpp.mli new file mode 100644 index 0000000..7a8e0ec --- /dev/null +++ b/lang_cpp/parsing/token_helpers_cpp.mli @@ -0,0 +1,41 @@ + +val is_space : Parser_cpp.token -> bool +val is_comment_or_space : Parser_cpp.token -> bool +val is_just_comment : Parser_cpp.token -> bool +val is_comment : Parser_cpp.token -> bool +val is_real_comment : Parser_cpp.token -> bool +val is_fake_comment : Parser_cpp.token -> bool +val is_not_comment : Parser_cpp.token -> bool + +val is_pp_instruction : Parser_cpp.token -> bool +val is_eof : Parser_cpp.token -> bool +val is_statement : Parser_cpp.token -> bool +val is_start_of_something : Parser_cpp.token -> bool +val is_binary_operator : Parser_cpp.token -> bool +val is_stuff_taking_parenthized : Parser_cpp.token -> bool +val is_static_cast_like : Parser_cpp.token -> bool +val is_basic_type : Parser_cpp.token -> bool +val is_binary_operator_except_star : Parser_cpp.token -> bool +val is_struct_like_keyword : Parser_cpp.token -> bool +val is_classkey_keyword : Parser_cpp.token -> bool + +val is_cpp_keyword : Parser_cpp.token -> bool +val is_really_cpp_keyword : Parser_cpp.token -> bool +val is_maybenot_cpp_keyword : Parser_cpp.token -> bool +val is_privacy_keyword: Parser_cpp.token -> bool + +val is_opar : Parser_cpp.token -> bool +val is_cpar : Parser_cpp.token -> bool +val is_obrace : Parser_cpp.token -> bool +val is_cbrace : Parser_cpp.token -> bool + +val is_ident_like: Parser_cpp.token -> bool + +val token_kind_of_tok: Parser_cpp.token -> Parse_info.token_kind + +val info_of_tok : + Parser_cpp.token -> Parse_info.info +val visitor_info_of_tok : + (Parse_info.info -> Parse_info.info) -> Parser_cpp.token -> Parser_cpp.token + +val line_of_tok : Parser_cpp.token -> int diff --git a/lang_cpp/parsing/token_views_context.ml b/lang_cpp/parsing/token_views_context.ml new file mode 100644 index 0000000..3e2b385 --- /dev/null +++ b/lang_cpp/parsing/token_views_context.ml @@ -0,0 +1,327 @@ +(* Yoann Padioleau + * + * Copyright (C) 2014 Facebook + * Copyright (C) 2002-2008 Yoann Padioleau + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +open Parser_cpp +open Token_views_cpp + +module TH = Token_helpers_cpp +module TV = Token_views_cpp + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(*****************************************************************************) +(* Argument vs Parameter *) +(*****************************************************************************) + +let look_like_argument _tok_before xs = + + (* normalize for C++ *) + let xs = xs +> List.map (function + | Tok ({t=TAnd ii} as record) -> Tok ({record with t=TMul ii}) + | x -> x + ) + in + (* split by comma so can easily check if have stuff like '*xx' + * that takes the full argument + *) + let xxs = split_comma xs in + + let aux1 xs = + match xs with + | [] -> false + (* *xx (note: actually can also be a function pointer decl) *) + | [Tok{t=TMul _}; Tok{t=TIdent _}] -> true + (* *(xx) *) + | [Tok{t=TMul _}; Parens _] -> true + (* TODO: xx * yy and space = 1 between the 2 :) *) + | _ -> false + in + + let rec aux xs = + match xs with + | [] -> false + (* a function call probably *) + | Tok{t=TIdent _}::Parens _::_xs -> + (* todo? look_like_argument recursively in Parens || aux xs ? *) + true + (* if have = ... then must stop, could be default parameter of a method *) + | Tok{t=TEq _}::_xs -> false + + (* could be part of a type declaration *) + | Tok {t=TOCro _}::Tok {t=TCCro _}::_xs -> false + | Tok {t=TOCro _}::Tok {t=(TInt _)}::Tok {t=TCCro _}::_xs -> false + | Tok {t=TOCro _}::Tok {t=(TIdent _)}::Tok {t=TCCro _}::_xs -> false + + | x::xs -> + (match x with + | Tok {t=(TInt _ | TFloat _ | TChar _ | TString _) } -> true + | Tok {t=(Ttrue _ | Tfalse _) } -> true + | Tok {t=(Tthis _)} -> true + | Tok {t=(Tnew _ )} -> true + | Tok {t= tok} when TH.is_binary_operator_except_star tok -> true + | Tok {t=(TInc _ | TDec _)} -> true + | Tok {t = (TDot _ | TPtrOp _ | TPtrOpStar _ | TDotStar _)} -> true + | Tok {t = (TOCro _)} -> true + | Tok {t = (TWhy _ | TBang _)} -> true + | _ -> aux xs + ) + in + (* todo? what if they contradict each other? if one say arg and + * the other a parameter? + *) + xxs +> List.exists aux1 || aux xs + +let look_like_typedef s = + s =~ ".*_t$" || + s = "ulong" || s = "uchar" || s = "uvlong" || s = "vlong" || s = "uintptr" + (* plan9, but actually some fp such as Paddr which is actually a macro *) + (* || s =~ "[A-Z][a-z].*$" *) + (* with DECLARE_BOOST_TYPE, but have some false positives + * when people do xx* indexPtr = const_cast<>(indexPtr); + *) + (* s =~ ".*Ptr$" *) + (* || s = "StringPiece" *) + + + +(* todo: pass1, look for const, etc + * todo: pass2, look xx_t, xx&, xx*, xx**, see heuristics in typedef + * + * Many patterns should mimic some heuristics in parsing_hack_typedef.ml + *) +let look_like_parameter tok_before xs = + + (* normalize for C++ *) + let xs = xs +> List.map (function + | Tok ({t=TAnd ii} as record) -> Tok ({record with t=TMul ii}) + | x -> x + ) + in + let xxs = split_comma xs in + + let aux1 xs = + match xs with + | [] -> false + (* xx_t *) + | [Tok {t=TIdent (s, _)}] when look_like_typedef s -> true + (* xx* *) + | [Tok {t=TIdent _}; Tok {t=TMul _}] -> true + (* xx** *) + | [Tok {t=TIdent _}; Tok {t=TMul _}; Tok {t=TMul _}] -> true + (* xx * y could be multiplication (or xx & yy) .. + * todo: could look if space around :) but because of the + * filtering of template and qualifier the no_space_between + * may not be completely accurate here. May need lower level access + * to the list of TCommentSpace and their position. + * hmm but can look at col? + * + * C-s for parameter_decl in grammar to see that catch() is + * a InParameter. + *) + | [Tok {t=TIdent _}; Tok {t=TMul _};Tok {t=TIdent _};] -> + (match tok_before with + | Tok{t=( + Tcatch _ + (* ugly: TIdent_Constructor interaction between past heuristics *) + | TIdent_Constructor _ + | Toperator _ + (* no! | TIdent _ *) + )} -> true + | _ -> false + ) + + | _ -> false + in + + let rec aux xs = + match xs with + | [] -> false + (* xx yy *) + | Tok {t=TIdent _}::Tok{t=TIdent _}::_xs -> true + | x::xs -> + (match x with + | Tok {t= tok} when TH.is_basic_type tok -> true + | Tok {t = (Tconst _ | Tvolatile _)} -> true + | Tok {t = (Tstruct _ | Tunion _ | Tenum _ | Tclass _)} -> true + | _ -> aux xs + ) + in + xxs +> List.exists aux1 || aux xs + + +(*****************************************************************************) +(* Main heuristics *) +(*****************************************************************************) +(* + * Most of the important contexts are introduced via some '{' '}'. To + * disambiguate is it often enough to just look at a few tokens before the + * '{'. + * + * Below we assume a view without: + * - comments + * - cpp directives + * + * todo + * - handle more C++ (right now I did it mostly to be able to parse plan9) + * - harder now that have c++, can have function inside struct so need + * handle all together. + * - change token but do not recurse in + * nested Braceised. maybe do via accumulator, don't use iter_token_brace? + * - need remove the qualifier as they make the sequence pattern matching + * more difficult? + *) +let set_context_tag_multi groups = + let rec aux xs = + match xs with + | [] -> () + + (* struct Foo {, also valid for class and union *) + | Tok{t=(Tstruct _ | Tunion _ | Tclass _)}::Tok{t=TIdent(s,_)} + ::(Braces(_t1, _body, _t2) as braces)::xs + -> + [braces] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- (TV.InClassStruct s)::tok.TV.where; + ); + aux (braces::xs) + + | Tok{t=(Tstruct _ | Tunion _)}::(Braces(_t1, _body, _t2) as braces)::xs + -> + [braces] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- (TV.InClassStruct "__anon__")::tok.TV.where; + ); + aux (braces::xs) + + (* = { } *) + | Tok ({t=TEq _; _})::(Braces(_t1, _body, _t2) as braces)::xs -> + [braces] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- InInitializer::tok.TV.where; + ); + aux (braces::xs) + + (* enum xxx { InEnum *) + | Tok{t=Tenum _}::Tok{t=TIdent(_,_)}::(Braces(_t1, _body, _t2) as braces)::xs + | Tok{t=Tenum _}::(Braces(_t1, _body, _t2) as braces)::xs + -> + [braces] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- TV.InEnum::tok.TV.where; + ); + aux (braces::xs) + + + (* C++: class Foo : ... { *) + | Tok{t=Tclass _ | Tstruct _}::Tok{t=TIdent(s,_)} + ::Tok{t= TCol ii}::xs + -> + let (before, braces, after) = + try + xs +> Common2.split_when (function + | Braces _ -> true + | _ -> false + ) + with Not_found -> + raise (UnclosedSymbol (spf "PB with split_when at %s" + (Parse_info.string_of_info ii))) + in + aux before; + [braces] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- (TV.InClassStruct s)::tok.TV.where; + ); + aux [braces]; + aux after + + + + (* need to look what was before to help the look_like_xxx heuristics + * + * The order of the 3 rules below is important. We must first try + * look_like_argument which has less FP than look_like_parameter + *) + | x::(Parens(_t1, body, _t2) as parens)::xs + when look_like_argument x body -> + (*msg_context t1.t (TV.InArgument); *) + [parens] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- (TV.InArgument)::tok.TV.where; + ); + (* todo? recurse on body? *) + aux [x]; + aux (parens::xs) + + (* C++: special cases *) + | (Tok{t=Toperator _} as tok1)::tok2::(Parens(_t1, body, _t2) as parens)::xs + when look_like_parameter tok1 body -> + (* msg_context t1.t (TV.InParameter); *) + [parens] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- (TV.InParameter)::tok.TV.where; + ); + (* recurse on body? hmm if InParameter should not have nested + * stuff except when pass function pointer + *) + aux [tok1;tok2]; + aux (parens::xs) + + + | x::(Parens(_t1, body, _t2) as parens)::xs + when look_like_parameter x body -> + (* msg_context t1.t (TV.InParameter); *) + [parens] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- (TV.InParameter)::tok.TV.where; + ); + (* recurse on body? hmm if InParameter should not have nested + * stuff except when pass function pointer + *) + aux [x]; + aux (parens::xs) + + (* void xx() *) + | Tok{t=typ}::Tok{t=TIdent _}::(Parens(_t1, _body, _t2) as parens)::xs + when TH.is_basic_type typ -> + (* msg_context t1.t (TV.InParameter); *) + [parens] +> TV.iter_token_multi (fun tok -> + tok.TV.where <- (TV.InParameter)::tok.TV.where; + ); + aux (parens::xs) + + + | x::xs -> + (match x with + | Tok _t -> () + | Parens (_t1, xs, _t2) + | Braces (_t1, xs, _t2) + | Angle (_t1, xs, _t2) + -> + aux xs + ); + aux xs + in + (* sane initialization *) + groups +> TV.iter_token_multi (fun tok -> + tok.TV.where <- [TV.InTopLevel]; + ); + aux groups + +(*****************************************************************************) +(* Main heuristics C++ *) +(*****************************************************************************) +(* + * assumes a view without: + * - template arguments, qualifiers, + * - comments and cpp directives + * - TODO public/protected/... ? + *) +let set_context_tag_cplus groups = + set_context_tag_multi groups diff --git a/lang_cpp/parsing/token_views_context.mli b/lang_cpp/parsing/token_views_context.mli new file mode 100644 index 0000000..097b68d --- /dev/null +++ b/lang_cpp/parsing/token_views_context.mli @@ -0,0 +1,10 @@ + +val set_context_tag_cplus: + Token_views_cpp.multi_grouped list -> unit + +val set_context_tag_multi: + Token_views_cpp.multi_grouped list -> unit + +(* todo: could be moved *) +val look_like_typedef: + string -> bool diff --git a/lang_cpp/parsing/token_views_cpp.ml b/lang_cpp/parsing/token_views_cpp.ml new file mode 100644 index 0000000..cdfe9a4 --- /dev/null +++ b/lang_cpp/parsing/token_views_cpp.ml @@ -0,0 +1,665 @@ +(* Yoann Padioleau + * + * Copyright (C) 2011, 2014 Facebook + * Copyright (C) 2007, 2008 Ecole des Mines de Nantes + * + * This program is free software; you can redistribute it and/or + * modify it under the terms of the GNU General Public License (GPL) + * version 2 as published by the Free Software Foundation. + * + * 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 + * file license.txt for more details. + *) +open Common + +module Flag = Flag_parsing_cpp +module PI = Parse_info +module TH = Token_helpers_cpp + +open Parser_cpp + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) +(* + * This module makes it easier to write some fuzzy parsing heuristics + * by offering different "views" over the same set of tokens. + * + * Normally I should not use ref/mutable in the token_extended type below + * and instead have a set of functions taking a list of tokens and + * returning a list of tokens. The problem is that to make easier some + * functions, it is better to work on better representation, on "views" + * over this list of tokens. But then modifying those views and get + * back from those views to the original simple list of tokens is + * tedious. One way is to maintain next to the view a list of "actions" + * (I was using a hash storing the charpos of the token and associating + * the action) but it is tedious too. Simpler to use mutable/ref. We + * use the same idea that we use when working on the Ast. + * + * old: when I was using the list of "actions" next to the views, the hash + * indexed by the charpos, there could have been some problems: + * how my fake_pos interact with the way I tag and adjust token ? + * because I base my tagging on the position of the token ! so sometimes + * could tag another fakeInfo that should not be tagged ? + * fortunately I don't use anymore this technique. + *) + +(*****************************************************************************) +(* Some debugging functions *) +(*****************************************************************************) +let pr2, _pr2_once = Common2.mk_pr2_wrappers Flag.verbose_parsing + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +type token_extended = { + (* chose 't' and not 'tok' to have a short name because we will write + * lots of ocaml patterns around this ... so better to be short + *) + mutable t: Parser_cpp.token; + (* In C++ we have functions inside classes, so need a stack of context *) + mutable where: context list; + + (* less: need also a after ? *) + mutable new_tokens_before : Parser_cpp.token list; + + (* line x col cache (more easily accessible) of the info in the token *) + line: int; + col : int; +} + (* The strategy to tag is mostly to look at the token(s) before the '{' *) + and context = + | InTopLevel + | InClassStruct of string (* can be __anon__ *) | InEnum + | InInitializer + | InAssign + | InParameter | InArgument + (* TODO actually commented in token_view_context because of c++ *) + | InFunction +(* + | InTemplateParam (* TODO *) +*) + +(* InCondition ? InParenExpr ? *) + +(* x list list, because x list separated by ',' *) +type paren_grouped = + | Parenthised of paren_grouped list list * token_extended list + | PToken of token_extended + +type brace_grouped = + | Braceised of + brace_grouped list list * token_extended * token_extended option + | BToken of token_extended + +(* Far better data structure than doing hacks in the lexer or parser + * because in lexer we don't know to which ifdef a endif is related + * and so when we want to comment a ifdef, we don't know which endif + * we must also comment. Especially true for the #if 0 which sometimes + * have a #else part. + * + * x list list, because x list separated by #else or #elif + *) +type ifdef_grouped = + | Ifdef of ifdef_grouped list list * token_extended list + | Ifdefbool of bool * ifdef_grouped list list * token_extended list + | NotIfdefLine of token_extended list + + +type 'a line_grouped = + Line of 'a list + + +type body_function_grouped = + | BodyFunction of token_extended list + | NotBodyLine of token_extended list + +(* quite similar to ast_fuzzy.ml but with extended token *) +type multi_grouped = + | Braces of token_extended * multi_grouped list * token_extended option + | Parens of token_extended * multi_grouped list * token_extended option + | Angle of token_extended * multi_grouped list * token_extended option + | Tok of token_extended + + (* with tarzan *) + +exception UnclosedSymbol of string + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +let mk_token_extended x = + let info = TH.info_of_tok x in + let (line, col) = PI.line_of_info info, PI.col_of_info info in + { t = x; + line = line; col = col; + (* we use List.hd at a few places, so convenient to have a sentinel *) + where = [InTopLevel]; + new_tokens_before = []; + } + +let mk_token_fake x = + { t = x; + line = -1; col = -1; + where = [InTopLevel]; + new_tokens_before = []; + } + +let rebuild_tokens_extented toks_ext = + let _tokens = ref [] in + toks_ext +> List.iter (fun tok -> + tok.new_tokens_before +> List.iter (fun x -> push x _tokens); + push tok.t _tokens + ); + let tokens = List.rev !_tokens in + (tokens +> Common2.acc_map mk_token_extended) + +(*****************************************************************************) +(* View builders *) +(*****************************************************************************) + +(* ------------------------------------------------------------------------- *) +(* Parens *) +(* ------------------------------------------------------------------------- *) + +(* todo: synchro ! use more indentation + * if paren not closed and same indentation level, certainly because + * part of a mid-ifdef-expression. + * + * c++ext: TODO: need to handle templates here. + * The parenthized view must not consider the ',' in expressions + * like foo(lexical cast, ...) as a separator for the arguments + * of foo(), otherwise we will get [lexical_castTInf_Template translation. + *) +let rec mk_parenthised xs = + match xs with + | [] -> [] + | x::xs -> + (match x.t with + | xx when TH.is_opar xx -> + let body, extras, xs = mk_parameters [x] [] xs in + Parenthised (body,extras)::mk_parenthised xs + | _ -> + PToken x::mk_parenthised xs + ) + +(* return the body of the parenthised expression and the rest of the tokens *) +and mk_parameters extras acc_before_sep xs = + match xs with + | [] -> + (* maybe because of #ifdef which "opens" '(' in 2 branches *) + pr2 "PB: not found closing paren in fuzzy parsing"; + [List.rev acc_before_sep], List.rev extras, [] + | x::xs -> + (match x.t with + (* synchro *) + | xx when TH.is_obrace xx && x.col = 0 -> + pr2 "PB: found synchro point } in paren"; + [List.rev acc_before_sep], List.rev (extras), (x::xs) + + | xx when TH.is_cpar xx -> + [List.rev acc_before_sep], List.rev (x::extras), xs + | xx when TH.is_opar xx -> + let body, extrasnest, xs = mk_parameters [x] [] xs in + mk_parameters extras + (Parenthised (body,extrasnest)::acc_before_sep) + xs + | TComma _ -> + let body, extras, xs = mk_parameters (x::extras) [] xs in + (List.rev acc_before_sep)::body, extras, xs + | _ -> + mk_parameters extras (PToken x::acc_before_sep) xs + ) + +(* ------------------------------------------------------------------------- *) +(* Brace *) +(* ------------------------------------------------------------------------- *) + +let rec mk_braceised xs = + match xs with + | [] -> [] + | x::xs -> + (match x.t with + | xx when TH.is_obrace xx -> + let body, endbrace, xs = mk_braceised_aux [] xs in + Braceised (body, x, endbrace)::mk_braceised xs + | xx when TH.is_cbrace xx -> + pr2 "PB: found closing brace alone in fuzzy parsing"; + BToken x::mk_braceised xs + | _ -> + BToken x::mk_braceised xs + ) + +(* return the body of the parenthised expression and the rest of the tokens *) +and mk_braceised_aux acc xs = + match xs with + | [] -> + (* maybe because of #ifdef which "opens" '(' in 2 branches *) + pr2 "PB: not found closing brace in fuzzy parsing"; + [List.rev acc], None, [] + | x::xs -> + (match x.t with + | xx when TH.is_cbrace xx -> [List.rev acc], Some x, xs + | xx when TH.is_obrace xx -> + let body, endbrace, xs = mk_braceised_aux [] xs in + mk_braceised_aux (Braceised (body,x, endbrace)::acc) xs + | _ -> + mk_braceised_aux (BToken x::acc) xs + ) + +(* ------------------------------------------------------------------------- *) +(* Ifdefs *) +(* ------------------------------------------------------------------------- *) +let rec mk_ifdef xs = + match xs with + | [] -> [] + | x::xs -> + (match x.t with + | TIfdef _ -> + let body, extra, xs = mk_ifdef_parameters [x] [] xs in + Ifdef (body, extra)::mk_ifdef xs + | TIfdefBool (b,_) -> + let body, extra, xs = mk_ifdef_parameters [x] [] xs in + + (* if not passing, then consider a #if 0 as an ordinary #ifdef *) + if !Flag.if0_passing + then Ifdefbool (b, body, extra)::mk_ifdef xs + else Ifdef(body, extra)::mk_ifdef xs + + | TIfdefMisc (b,_) | TIfdefVersion (b,_) -> + let body, extra, xs = mk_ifdef_parameters [x] [] xs in + Ifdefbool (b, body, extra)::mk_ifdef xs + + + | _ -> + (* todo? can have some Ifdef in the line ? *) + let line, xs = Common.span (fun y -> y.line = x.line) (x::xs) in + NotIfdefLine line::mk_ifdef xs + ) + +and mk_ifdef_parameters extras acc_before_sep xs = + match xs with + | [] -> + (* Note that mk_ifdef is assuming that CPP instruction are alone + * on their line. Because I do a span (fun x -> is_same_line ...) + * I might take with me a #endif if this one is mixed on a line + * with some "normal" tokens. + *) + pr2 "PB: not found closing ifdef in fuzzy parsing"; + [List.rev acc_before_sep], List.rev extras, [] + | x::xs -> + (match x.t with + | TEndif _ -> + [List.rev acc_before_sep], List.rev (x::extras), xs + | TIfdef _ -> + let body, extrasnest, xs = mk_ifdef_parameters [x] [] xs in + mk_ifdef_parameters + extras (Ifdef (body, extrasnest)::acc_before_sep) xs + + | TIfdefBool (b,_) -> + let body, extrasnest, xs = mk_ifdef_parameters [x] [] xs in + + if !Flag.if0_passing + then + mk_ifdef_parameters + extras (Ifdefbool (b, body, extrasnest)::acc_before_sep) xs + else + mk_ifdef_parameters + extras (Ifdef (body, extrasnest)::acc_before_sep) xs + + + | TIfdefMisc (b,_) | TIfdefVersion (b,_) -> + let body, extrasnest, xs = mk_ifdef_parameters [x] [] xs in + mk_ifdef_parameters + extras (Ifdefbool (b, body, extrasnest)::acc_before_sep) xs + + | TIfdefelse _ + | TIfdefelif _ -> + let body, extras, xs = mk_ifdef_parameters (x::extras) [] xs in + (List.rev acc_before_sep)::body, extras, xs + | _ -> + let line, xs = Common.span (fun y -> y.line = x.line) (x::xs) in + mk_ifdef_parameters extras (NotIfdefLine line::acc_before_sep) xs + ) + +(* ------------------------------------------------------------------------- *) +(* Lines (of parens) *) +(* ------------------------------------------------------------------------- *) + +let line_of_paren = function + | PToken x -> x.line + | Parenthised (_xxs, info_parens) -> + (match info_parens with + | [] -> raise Impossible + | x::_xs -> x.line + ) + + +(* old +let rec span_line_paren line = function + | [] -> [],[] + | x::xs -> + (match x with + | PToken tok when TH.is_eof tok.t -> + [], x::xs + | _ -> + if line_of_paren x = line + then + let (l1, l2) = span_line_paren line xs in + (x::l1, l2) + else ([], x::xs) + ) + +let rec mk_line_parenthised xs = + match xs with + | [] -> [] + | x::xs -> + let line_no = line_of_paren x in + let line, xs = span_line_paren line_no xs in + Line (x::line)::mk_line_parenthised xs +*) + +let line_range_of_paren = function + | PToken x -> x.line, x.line + | Parenthised (_xxs, info_parens) -> + (match info_parens with + | [] -> raise Impossible + | x::xs -> + let lines_no = (x::xs) +> List.map (fun x -> x.line) in + Common2.minimum lines_no, Common2.maximum lines_no + ) + +let rec span_line_paren_range (imin, imax) = function + | [] -> [],[] + | x::xs -> + (match x with + | PToken tok when TH.is_eof tok.t -> + [], x::xs + | _ -> + if line_of_paren x >= imin && line_of_paren x <= imax + then + (* may need to extend *) + let (_imin', imax') = line_range_of_paren x in + let (l1, l2) = span_line_paren_range (imin, max imax imax') xs in + (x::l1, l2) + else ([], x::xs) + ) + + +let rec mk_line_parenthised xs = + match xs with + | [] -> [] + | x::xs -> + let line_range = line_range_of_paren x in + let line, xs = span_line_paren_range line_range xs in + Line (x::line)::mk_line_parenthised xs + +(* ------------------------------------------------------------------------- *) +(* Function body *) +(* ------------------------------------------------------------------------- *) +let rec mk_body_function_grouped xs = + match xs with + | [] -> [] + | x::xs -> + (match x with + | {t=TOBrace _; col = 0; _} -> + let is_closing_brace = function + | {t = TCBrace _; col = 0; _ } -> true + | _ -> false + in + let body, xs = Common.span (fun x -> not (is_closing_brace x)) xs in + (match xs with + | ({t = TCBrace _; col = 0; _ })::xs -> + BodyFunction body::mk_body_function_grouped xs + | [] -> + pr2 "PB:not found closing brace in fuzzy parsing"; + [NotBodyLine body] + | _ -> raise Impossible + ) + + | _ -> + let line, xs = Common.span (fun y -> y.line = x.line) (x::xs) in + NotBodyLine line::mk_body_function_grouped xs + ) + +(* ------------------------------------------------------------------------- *) +(* Multi ('{', '(', '<') (could also do '[' ?) *) +(* ------------------------------------------------------------------------- *) + +(* Assumes work on a list of tokens without comments, without ifdefs + * (todo? and without #define?). + * Used for typedef inference. Now also used for fuzzy parsing! + * + * todo? more fault tolerance, if col == 0 and { the reset! + * less: could check that it's consistent with the indentation + * + *) +let mk_multi xs = + + let rec consume x xs = + match x with + | {t=(*TOBrace ii*)tok;_} when TH.is_obrace tok -> + let body, closing, rest = look_close_brace x [] xs in + Braces (x, body, closing), rest + | {t=(*TOPar ii*)tok;_} when TH.is_opar tok -> + let body, closing, rest = look_close_paren x [] xs in + Parens (x, body, closing), rest + | {t=TInf_Template _ii;_} -> + let body, closing, rest = look_close_template x [] xs in + Angle (x, body, closing), rest + | x -> Tok x, xs + + and aux xs = + match xs with + | [] -> [] + | x::xs -> + let x', xs' = consume x xs in + x'::aux xs' + + and look_close_brace tok_start accbody xs = + match xs with + | [] -> + raise (UnclosedSymbol (spf "PB look_close_brace (started at %d)" + (TH.line_of_tok tok_start.t))) + | x::xs -> + (match x with + | {t=TCBrace _ii;_} -> List.rev accbody, Some x, xs + + (* Many macros have unclosed '{'. An alternative + * would be to work on a view where define has been filtered + *) + | {t=TCommentNewline_DefineEndOfMacro _ii;_} -> + List.rev accbody, None, x::xs + + | _ -> let (x', xs') = consume x xs in + look_close_brace tok_start (x'::accbody) xs' + ) + + and look_close_paren tok_start accbody xs = + match xs with + | [] -> + raise (UnclosedSymbol (spf "PB look_close_paren (started at %d)" + (TH.line_of_tok tok_start.t))) + | x::xs -> + (match x with + | {t=(*TCPar ii*)tok;_} when TH.is_cpar tok -> + List.rev accbody, Some x, xs + | _ -> + let (x', xs') = consume x xs in + look_close_paren tok_start (x'::accbody) xs' + ) + + and look_close_template tok_start accbody xs = + match xs with + | [] -> + raise (UnclosedSymbol (spf "PB look_close_template (started at %d)" + (TH.line_of_tok tok_start.t))) + | x::xs -> + (match x with + | {t=TSup_Template _ii;_} -> List.rev accbody, Some x, xs + | _ -> let (x', xs') = consume x xs in + look_close_template tok_start (x'::accbody) xs' + ) + in + aux xs + +let split_comma xs = + xs +> Common2.split_gen_when (function + | Tok{t=TComma _;_}::xs -> Some xs + | _ -> None + ) + +(*****************************************************************************) +(* View iterators *) +(*****************************************************************************) + +let rec iter_token_paren f xs = + xs +> List.iter (function + | PToken tok -> f tok; + | Parenthised (xxs, info_parens) -> + info_parens +> List.iter f; + xxs +> List.iter (fun xs -> iter_token_paren f xs) + ) + +let rec iter_token_brace f xs = + xs +> List.iter (function + | BToken tok -> f tok; + | Braceised (xxs, tok1, tok2opt) -> + f tok1; do_option f tok2opt; + xxs +> List.iter (fun xs -> iter_token_brace f xs) + ) + +let rec iter_token_ifdef f xs = + xs +> List.iter (function + | NotIfdefLine xs -> xs +> List.iter f; + | Ifdefbool (_, xxs, info_ifdef) + | Ifdef (xxs, info_ifdef) -> + info_ifdef +> List.iter f; + xxs +> List.iter (iter_token_ifdef f) + ) + +let rec iter_token_multi f xs = + xs +> List.iter (function + | Tok t -> f t + | Braces (t1, xs, t2) + | Parens (t1, xs, t2) + | Angle (t1, xs, t2) + -> + f t1; + iter_token_multi f xs; + Common.do_option f t2 + ) + +let tokens_of_paren xs = + let g = ref [] in + xs +> iter_token_paren (fun tok -> push tok g); + List.rev !g + + +let tokens_of_paren_ordered xs = + let g = ref [] in + + let rec aux_tokens_ordered = function + | PToken tok -> push tok g; + | Parenthised (xxs, info_parens) -> + let (opar, cpar, commas) = + match info_parens with + | opar::xs -> + (match List.rev xs with + | cpar::xs -> + opar, cpar, List.rev xs + | _ -> raise Impossible + ) + | _ -> raise Impossible + in + push opar g; + aux_args (xxs,commas); + push cpar g; + + and aux_args (xxs, commas) = + match xxs, commas with + | [], [] -> () + | [xs], [] -> xs +> List.iter aux_tokens_ordered + | xs::ys::xxs, comma::commas -> + xs +> List.iter aux_tokens_ordered; + push comma g; + aux_args (ys::xxs, commas) + | _ -> raise Impossible + + in + + xs +> List.iter aux_tokens_ordered; + List.rev !g + +let tokens_of_multi_grouped xs = + let res = ref [] in + + let add x = Common.push x res in + + let rec aux xs = + xs +> List.iter (function + | Tok t1 -> add t1 + | Braces (t1, xs, t2) + | Parens (t1, xs, t2) + | Angle (t1, xs, t2) -> + add t1; + aux xs; + Common.do_option add t2 + ) + in + aux xs; + List.rev !res + +(*****************************************************************************) +(* vof *) +(*****************************************************************************) + +let vof_context = function + | InTopLevel -> Ocaml.VSum ("T", []) + | InClassStruct _s -> Ocaml.VSum ("C", []) + | InEnum -> Ocaml.VSum ("E", []) + | InInitializer -> Ocaml.VSum ("I", []) + | InAssign -> Ocaml.VSum ("=", []) + | InParameter -> Ocaml.VSum ("P", []) + | InArgument -> Ocaml.VSum ("A", []) + | InFunction -> Ocaml.VSum ("F", []) +(* + | InTemplateParam -> Ocaml.VSum ("<>", []) +*) + +let vof_token_extended t = + let info = TH.info_of_tok t.t in + let str = PI.str_of_info info in + let xs = List.map vof_context t.where in + Ocaml.VTuple [Ocaml.VString str; Ocaml.VList xs] + +let rec vof_multi_grouped = + function + | Braces ((v1, v2, v3)) -> + let v1 = vof_token_extended v1 + and v2 = Ocaml.vof_list vof_multi_grouped v2 + and v3 = Ocaml.vof_option vof_token_extended v3 + in Ocaml.VSum (("Braces", [ v1; v2; v3 ])) + | Parens ((v1, v2, v3)) -> + let v1 = vof_token_extended v1 + and v2 = Ocaml.vof_list vof_multi_grouped v2 + and v3 = Ocaml.vof_option vof_token_extended v3 + in Ocaml.VSum (("Parens", [ v1; v2; v3 ])) + | Angle ((v1, v2, v3)) -> + let v1 = vof_token_extended v1 + and v2 = Ocaml.vof_list vof_multi_grouped v2 + and v3 = Ocaml.vof_option vof_token_extended v3 + in Ocaml.VSum (("Angle", [ v1; v2; v3 ])) + | Tok v1 -> let v1 = vof_token_extended v1 in Ocaml.VSum (("Tok", [ v1 ])) + + +let vof_multi_grouped_list xs = + let v = Ocaml.VList (xs +> List.map vof_multi_grouped) in + v diff --git a/lang_cpp/parsing/token_views_cpp.mli b/lang_cpp/parsing/token_views_cpp.mli new file mode 100644 index 0000000..94c227b --- /dev/null +++ b/lang_cpp/parsing/token_views_cpp.mli @@ -0,0 +1,72 @@ + +type token_extended = { + mutable t: Parser_cpp.token; + mutable where : context list; + mutable new_tokens_before : Parser_cpp.token list; + line : int; + col : int; +} + and context = + | InTopLevel + | InClassStruct of string + | InEnum + | InInitializer + | InAssign + | InParameter + | InArgument + | InFunction +(* + | InTemplateParam +*) + +val mk_token_extended : Parser_cpp.token -> token_extended +val mk_token_fake : Parser_cpp.token -> token_extended +val rebuild_tokens_extented : token_extended list -> token_extended list + +type paren_grouped = + | Parenthised of paren_grouped list list * token_extended list + | PToken of token_extended +type brace_grouped = + | Braceised of brace_grouped list list * token_extended * + token_extended option + | BToken of token_extended + +type ifdef_grouped = + | Ifdef of ifdef_grouped list list * token_extended list + | Ifdefbool of bool * ifdef_grouped list list * token_extended list + | NotIfdefLine of token_extended list + +type 'a line_grouped = + Line of 'a list + +type body_function_grouped = + | BodyFunction of token_extended list + | NotBodyLine of token_extended list + +type multi_grouped = + | Braces of token_extended * multi_grouped list * token_extended option + | Parens of token_extended * multi_grouped list * token_extended option + | Angle of token_extended * multi_grouped list * token_extended option + | Tok of token_extended + +val split_comma: multi_grouped list -> multi_grouped list list + +val mk_parenthised: token_extended list -> paren_grouped list +val mk_braceised: token_extended list -> brace_grouped list +val mk_ifdef: token_extended list -> ifdef_grouped list +val mk_body_function_grouped: token_extended list -> body_function_grouped list +val mk_line_parenthised: paren_grouped list -> paren_grouped line_grouped list + +exception UnclosedSymbol of string +val mk_multi: token_extended list -> multi_grouped list + +val iter_token_paren : (token_extended -> unit) -> paren_grouped list -> unit +val iter_token_brace : (token_extended -> unit) -> brace_grouped list -> unit +val iter_token_ifdef : (token_extended -> unit) -> ifdef_grouped list -> unit +val iter_token_multi : (token_extended -> unit) -> multi_grouped list -> unit + +val tokens_of_paren: paren_grouped list -> token_extended list +val tokens_of_paren_ordered: paren_grouped list -> token_extended list +val tokens_of_multi_grouped: multi_grouped list -> token_extended list + +val vof_multi_grouped_list: multi_grouped list -> Ocaml.v diff --git a/lang_cpp/parsing/type_cpp.ml b/lang_cpp/parsing/type_cpp.ml new file mode 100644 index 0000000..549a227 --- /dev/null +++ b/lang_cpp/parsing/type_cpp.ml @@ -0,0 +1,42 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) + +open Ast_cpp + +module Ast = Ast_cpp + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(*****************************************************************************) +(* Accessors *) +(*****************************************************************************) + +let is_function_type x = + match Ast.unwrap_typeC x with + | FunctionType _ -> true + | _ -> false + +let rec is_method_type x = + match Ast.unwrap_typeC x with + | Pointer y -> + is_method_type y + | ParenType paren_ft -> + is_method_type (Ast.unparen paren_ft) + | FunctionType _ -> + true + | _ -> false + diff --git a/lang_cpp/parsing/type_cpp.mli b/lang_cpp/parsing/type_cpp.mli new file mode 100644 index 0000000..a572884 --- /dev/null +++ b/lang_cpp/parsing/type_cpp.mli @@ -0,0 +1,4 @@ + +val is_function_type: Ast_cpp.fullType -> bool + +val is_method_type: Ast_cpp.fullType -> bool diff --git a/lang_cpp/parsing/unit_parsing_cpp.ml b/lang_cpp/parsing/unit_parsing_cpp.ml new file mode 100644 index 0000000..6e3aa5d --- /dev/null +++ b/lang_cpp/parsing/unit_parsing_cpp.ml @@ -0,0 +1,80 @@ +open Common +open OUnit + +module Ast = Ast_cpp +module Flag = Flag_parsing_cpp + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) +let parse file = + Common.save_excursion Flag.error_recovery false (fun () -> + Common.save_excursion Flag.show_parsing_error false (fun () -> + Common.save_excursion Flag.verbose_parsing false (fun () -> + Parse_cpp.parse file + ))) +(*****************************************************************************) +(* Unit tests *) +(*****************************************************************************) + +let unittest = + "parsing_cpp" >::: [ + + (*-----------------------------------------------------------------------*) + (* Lexing *) + (*-----------------------------------------------------------------------*) + (* todo: + * - make sure parse int correctly, and float, and that actually does + * not return multiple tokens for 42.42 + * - ... + *) + + (*-----------------------------------------------------------------------*) + (* Parsing *) + (*-----------------------------------------------------------------------*) + "regression files" >:: (fun () -> + let dir = Filename.concat Config_pfff.path "/tests/cpp/parsing" in + let files = + Common2.glob (spf "%s/*.cpp" dir) @ Common2.glob (spf "%s/*.h" dir) in + files +> List.iter (fun file -> + try + let _ast = parse file in + () + with Parse_cpp.Parse_error _ -> + assert_failure (spf "it should correctly parse %s" file) + ) + ); + + "rejecting bad code" >:: (fun () -> + let dir = Filename.concat Config_pfff.path "/tests/cpp/parsing_errors" in + let files = Common2.glob (spf "%s/*.cpp" dir) in + files +> List.iter (fun file -> + try + let _ast = parse file in + assert_failure (spf "it should have thrown a Parse_error %s" file) + with + | Parse_cpp.Parse_error _ -> () + | exn -> assert_failure (spf "throwing wrong exn %s on %s" + (Common.exn_to_s exn) file) + ) + ); + + (* parsing C files (and not C++ files) possibly containing C++ keywords *) + "C regression files" >:: (fun () -> + let dir = Filename.concat Config_pfff.path "/tests/c/parsing" in + let files = + Common2.glob (spf "%s/*.c" dir) + (* @ Common2.glob (spf "%s/*.h" dir) *) in + files +> List.iter (fun file -> + try + let _ast = parse file in + () + with Parse_cpp.Parse_error _ -> + assert_failure (spf "it should correctly parse %s" file) + ) + ); + + (*-----------------------------------------------------------------------*) + (* Misc *) + (*-----------------------------------------------------------------------*) + ] diff --git a/lang_cpp/parsing/unit_parsing_cpp.mli b/lang_cpp/parsing/unit_parsing_cpp.mli new file mode 100644 index 0000000..271d7b2 --- /dev/null +++ b/lang_cpp/parsing/unit_parsing_cpp.mli @@ -0,0 +1,5 @@ +(* Returns the testsuite for this directory. To be concatenated by + * the caller (e.g. in pfff/main_test.ml ) with other testsuites and + * run via OUnit.run_test_tt + *) +val unittest: OUnit.test diff --git a/lang_cpp/parsing/visitor_cpp.ml b/lang_cpp/parsing/visitor_cpp.ml new file mode 100644 index 0000000..a104212 --- /dev/null +++ b/lang_cpp/parsing/visitor_cpp.ml @@ -0,0 +1,879 @@ +(* Yoann Padioleau + * + * Copyright (C) 2010 Facebook + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public License + * version 2.1 as published by the Free Software Foundation, with the + * special exception on linking described in file license.txt. + * + * This library 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 file + * license.txt for more details. + *) + +open Ocaml +open Ast_cpp + +(*****************************************************************************) +(* Prelude *) +(*****************************************************************************) + +(*****************************************************************************) +(* Types *) +(*****************************************************************************) + +(* hooks *) +type visitor_in = { + kexpr: expression vin; + kstmt: statement vin; + kinit: initialiser vin; + ktypeC: typeC vin; + + kclass_member: class_member vin; + kfieldkind: fieldkind vin; + + kparameter: parameter vin; + kcompound: compound vin; + + kclass_def: class_definition vin; + kfunc_def: func_definition vin; + kcpp: cpp_directive vin; + kblock_decl: block_declaration vin; + + kdeclaration: declaration vin; + ktoplevel: toplevel vin; + + kinfo: tok vin; +} +and visitor_out = any -> unit +and 'a vin = ('a -> unit) * visitor_out -> 'a -> unit + +let default_visitor = + { kexpr = (fun (k,_) x -> k x); + kfieldkind = (fun (k,_) x -> k x); + kparameter = (fun (k,_) x -> k x); + ktypeC = (fun (k,_) x -> k x); + kblock_decl = (fun (k,_) x -> k x); + kcompound = (fun (k,_) x -> k x); + kstmt = (fun (k,_) x -> k x); + kinfo = (fun (k,_) x -> k x); + kclass_def = (fun (k,_) x -> k x); + kfunc_def = (fun (k,_) x -> k x); + kclass_member = (fun (k,_) x -> k x); + kcpp = (fun (k,_) x -> k x); + kdeclaration = (fun (k,_) x -> k x); + ktoplevel = (fun (k,_) x -> k x); + kinit = (fun (k,_) x -> k x); + } + + +let (mk_visitor: visitor_in -> visitor_out) = fun vin -> + +(* start of auto generation *) +(* generated by ocamltarzan with: camlp4o -o /tmp/yyy.ml -I pa/ pa_type_conv.cmo pa_visitor.cmo pr_o.cmo /tmp/xxx.ml *) + +let rec v_info x = + let k _ = () in + vin.kinfo (k, all_functions) x + +and v_tok v = v_info v + +and v_wrap:'a. ('a -> unit) -> 'a wrap -> unit = + fun _of_a (v1, v2) -> + let v1 = _of_a v1 and v2 = v_list v_info v2 in () +and v_wrap2:'a. ('a -> unit) -> 'a wrap2 -> unit = + fun _of_a (v1, v2) -> + let v1 = _of_a v1 and v2 = v_info v2 in () +and v_paren:'a. ('a -> unit) -> 'a paren -> unit = + fun _of_a (v1, v2, v3) -> + let v1 = v_tok v1 and v2 = _of_a v2 and v3 = v_tok v3 in () +and v_brace: 'a. ('a -> unit) -> 'a brace -> unit = + fun _of_a (v1, v2, v3) -> + let v1 = v_tok v1 and v2 = _of_a v2 and v3 = v_tok v3 in () +and v_bracket: 'a. ('a -> unit) -> 'a bracket -> unit = + fun _of_a (v1, v2, v3) -> + let v1 = v_tok v1 and v2 = _of_a v2 and v3 = v_tok v3 in () +and v_angle: 'a. ('a -> unit) -> 'a angle -> unit = + fun _of_a (v1, v2, v3) -> + let v1 = v_tok v1 and v2 = _of_a v2 and v3 = v_tok v3 in () +and v_comma_list: 'a. ('a -> unit) -> 'a comma_list -> unit = fun + _of_a -> v_list (v_wrap _of_a) +and v_comma_list2: 'a. ('a -> unit) -> 'a comma_list2 -> unit = + fun _of_a -> + v_list (Ocaml.v_either _of_a v_tok) + +and v_name (v1, v2, v3) = + let v1 = v_option v_tok v1 + and v2 = + v_list (fun (v1, v2) -> let v1 = v_qualifier v1 and v2 = v_tok v2 in ()) + v2 + and v3 = v_ident v3 + in () + +and v_ident = + function + | IdIdent v1 -> let v1 = v_wrap2 v_string v1 in () + | IdOperator ((v1, v2)) -> + let v1 = v_tok v1 + and v2 = + (match v2 with + | (v1, v2) -> let v1 = v_operator v1 and v2 = v_list v_tok v2 in ()) + in () + | IdConverter ((v1, v2)) -> let v1 = v_tok v1 and v2 = v_fullType v2 in () + | IdDestructor ((v1, v2)) -> + let v1 = v_tok v1 and v2 = v_wrap2 v_string v2 in () + | IdTemplateId ((v1, v2)) -> + let v1 = v_wrap2 v_string v1 and v2 = v_template_arguments v2 in () +and v_template_arguments v = v_angle (v_comma_list v_template_argument) v +and v_template_argument v = Ocaml.v_either v_fullType v_expression v +and v_either_ft_or_expr v = Ocaml.v_either v_fullType v_expression v +and v_qualifier = + function + | QClassname v1 -> let v1 = v_wrap2 v_string v1 in () + | QTemplateId ((v1, v2)) -> + let v1 = v_wrap2 v_string v1 and v2 = v_template_arguments v2 in () +and v_class_name v = v_name v +and v_namespace_name v = v_name v +and v_typedef_name v = v_name v +and v_enum_name v = v_name v +and v_ident_name v = v_name v +and v_fullType (v1, v2) = + let v1 = v_typeQualifier v1 and v2 = v_typeC v2 in () +and v_typeC v = + let k v = v_wrap v_typeCbis v in + vin.ktypeC (k, all_functions) v + +and v_typeCbis = + function + | BaseType v1 -> let v1 = v_baseType v1 in () + | Pointer v1 -> let v1 = v_fullType v1 in () + | Reference v1 -> let v1 = v_fullType v1 in () + | Array ((v1, v2)) -> + let v1 = v_bracket (v_option v_constExpression) v1 + and v2 = v_fullType v2 + in () + | FunctionType v1 -> let v1 = v_functionType v1 in () + | EnumDef ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_option (v_wrap2 v_string) v2 + and v3 = v_brace (v_comma_list v_enum_elem) v3 + in () + | StructDef v1 -> let v1 = v_class_definition v1 in () + | EnumName ((v1, v2)) -> + let v1 = v_tok v1 and v2 = v_wrap2 v_string v2 in () + | StructUnionName ((v1, v2)) -> + let v1 = v_wrap2 v_structUnion v1 and v2 = v_wrap2 v_string v2 in () + | TypeName ((v1)) -> + let v1 = v_name v1 in () + | TypenameKwd ((v1, v2)) -> let v1 = v_tok v1 and v2 = v_name v2 in () + | TypeOf ((v1, v2)) -> + let v1 = v_tok v1 and v2 = v_paren v_either_ft_or_expr v2 in () + | ParenType v1 -> let v1 = v_paren v_fullType v1 in () +and v_baseType = + function + | Void -> () + | IntType v1 -> let v1 = v_intType v1 in () + | FloatType v1 -> let v1 = v_floatType v1 in () +and v_intType = + function + | CChar -> () + | Si v1 -> let v1 = v_signed v1 in () + | CBool -> () + | WChar_t -> () +and v_signed (v1, v2) = let v1 = v_sign v1 and v2 = v_base v2 in () +and v_base = + function + | CChar2 -> () + | CShort -> () + | CInt -> () + | CLong -> () + | CLongLong -> () +and v_sign = function | Signed -> () | UnSigned -> () +and v_floatType = function | CFloat -> () | CDouble -> () | CLongDouble -> () +and v_enum_elem { e_name = v_e_name; e_val = v_e_val } = + let arg = v_wrap2 v_string v_e_name in + let arg = + v_option + (fun (v1, v2) -> let v1 = v_tok v1 and v2 = v_constExpression v2 in ()) + v_e_val + in () +and v_typeQualifier { const = v_const; volatile = v_volatile } = + let arg = v_option v_tok v_const in + let arg = v_option v_tok v_volatile in () +and v_expression v = + let k x = v_wrap v_expressionbis x in + vin.kexpr (k, all_functions) v + +and v_expressionbis = + function + | Id ((v1, v2)) -> let v1 = v_name v1 and v2 = v_ident_info v2 in () + | C v1 -> let v1 = v_constant v1 in () + | Call ((v1, v2)) -> + let v1 = v_expression v1 + and v2 = v_paren (v_comma_list v_argument) v2 + in () + | CondExpr ((v1, v2, v3)) -> + let v1 = v_expression v1 + and v2 = v_option v_expression v2 + and v3 = v_expression v3 + in () + | Sequence ((v1, v2)) -> + let v1 = v_expression v1 and v2 = v_expression v2 in () + | Assignment ((v1, v2, v3)) -> + let v1 = v_expression v1 + and v2 = v_assignOp v2 + and v3 = v_expression v3 + in () + | Postfix ((v1, v2)) -> let v1 = v_expression v1 and v2 = v_fixOp v2 in () + | Infix ((v1, v2)) -> let v1 = v_expression v1 and v2 = v_fixOp v2 in () + | Unary ((v1, v2)) -> let v1 = v_expression v1 and v2 = v_unaryOp v2 in () + | Binary ((v1, v2, v3)) -> + let v1 = v_expression v1 + and v2 = v_binaryOp v2 + and v3 = v_expression v3 + in () + | ArrayAccess ((v1, v2)) -> + let v1 = v_expression v1 and v2 = v_bracket v_expression v2 in () + | RecordAccess ((v1, v2)) -> + let v1 = v_expression v1 and v2 = v_name v2 in () + | RecordPtAccess ((v1, v2)) -> + let v1 = v_expression v1 and v2 = v_name v2 in () + | RecordStarAccess ((v1, v2)) -> + let v1 = v_expression v1 and v2 = v_expression v2 in () + | RecordPtStarAccess ((v1, v2)) -> + let v1 = v_expression v1 and v2 = v_expression v2 in () + | SizeOfExpr ((v1, v2)) -> let v1 = v_tok v1 and v2 = v_expression v2 in () + | SizeOfType ((v1, v2)) -> + let v1 = v_tok v1 and v2 = v_paren v_fullType v2 in () + | Cast ((v1, v2)) -> + let v1 = v_paren v_fullType v1 and v2 = v_expression v2 in () + | StatementExpr v1 -> let v1 = v_paren v_compound v1 in () + | GccConstructor ((v1, v2)) -> + let v1 = v_paren v_fullType v1 + and v2 = v_brace (v_comma_list v_initialiser) v2 + in () + | This v1 -> let v1 = v_tok v1 in () + | ConstructedObject ((v1, v2)) -> + let v1 = v_fullType v1 + and v2 = v_paren (v_comma_list v_argument) v2 + in () + | TypeId ((v1, v2)) -> + let v1 = v_tok v1 and v2 = v_paren v_either_ft_or_expr v2 in () + | CplusplusCast ((v1, v2, v3)) -> + let v1 = v_wrap2 v_cast_operator v1 + and v2 = v_angle v_fullType v2 + and v3 = v_paren v_expression v3 + in () + | New ((v1, v2, v3, v4, v5)) -> + let v1 = v_option v_tok v1 + and v2 = v_tok v2 + and v3 = v_option (v_paren (v_comma_list v_argument)) v3 + and v4 = v_fullType v4 + and v5 = v_option (v_paren (v_comma_list v_argument)) v5 + in () + | Delete ((v1, v2)) -> + let v1 = v_option v_tok v1 and v2 = v_expression v2 in () + | DeleteArray ((v1, v2)) -> + let v1 = v_option v_tok v1 and v2 = v_expression v2 in () + | Throw v1 -> let v1 = v_option v_expression v1 in () + | ParenExpr v1 -> let v1 = v_paren v_expression v1 in () + | ExprTodo -> () +and v_ident_info { i_scope = _v_i_scope } = + (* todo? let arg = Scope_code.v_scope v_i_scope in () *) + () +and v_argument v = Ocaml.v_either v_expression v_weird_argument v +and v_weird_argument = + function + | ArgType v1 -> let v1 = v_fullType v1 in () + | ArgAction v1 -> let v1 = v_action_macro v1 in () +and v_action_macro = function | ActMisc v1 -> let v1 = v_list v_tok v1 in () +and v_constant = + function + | String v1 -> + let v1 = + (match v1 with + | (v1, v2) -> let v1 = v_string v1 and v2 = v_isWchar v2 in ()) + in () + | MultiString -> () + | Char v1 -> + let v1 = + (match v1 with + | (v1, v2) -> let v1 = v_string v1 and v2 = v_isWchar v2 in ()) + in () + | Int v1 -> let v1 = v_string v1 in () + | Float v1 -> + let v1 = + (match v1 with + | (v1, v2) -> let v1 = v_string v1 and v2 = v_floatType v2 in ()) + in () + | Bool v1 -> let v1 = v_bool v1 in () +and v_isWchar = function | IsWchar -> () | IsChar -> () +and v_unaryOp = + function + | GetRef -> () + | DeRef -> () + | UnPlus -> () + | UnMinus -> () + | Tilde -> () + | Not -> () + | GetRefLabel -> () +and v_assignOp = + function | SimpleAssign -> () | OpAssign v1 -> let v1 = v_arithOp v1 in () +and v_fixOp = function | Dec -> () | Inc -> () +and v_binaryOp = + function + | Arith v1 -> let v1 = v_arithOp v1 in () + | Logical v1 -> let v1 = v_logicalOp v1 in () +and v_arithOp = + function + | Plus -> () + | Minus -> () + | Mul -> () + | Div -> () + | Mod -> () + | DecLeft -> () + | DecRight -> () + | And -> () + | Or -> () + | Xor -> () +and v_logicalOp = + function + | Inf -> () + | Sup -> () + | InfEq -> () + | SupEq -> () + | Eq -> () + | NotEq -> () + | AndLog -> () + | OrLog -> () +and v_ptrOp = function | PtrStarOp -> () | PtrOp -> () +and v_allocOp = + function + | NewOp -> () + | DeleteOp -> () + | NewArrayOp -> () + | DeleteArrayOp -> () +and v_accessop = function | ParenOp -> () | ArrayOp -> () +and v_operator = + function + | BinaryOp v1 -> let v1 = v_binaryOp v1 in () + | AssignOp v1 -> let v1 = v_assignOp v1 in () + | FixOp v1 -> let v1 = v_fixOp v1 in () + | PtrOpOp v1 -> let v1 = v_ptrOp v1 in () + | AccessOp v1 -> let v1 = v_accessop v1 in () + | AllocOp v1 -> let v1 = v_allocOp v1 in () + | UnaryTildeOp -> () + | UnaryNotOp -> () + | CommaOp -> () +and v_cast_operator = + function + | Static_cast -> () + | Dynamic_cast -> () + | Const_cast -> () + | Reinterpret_cast -> () +and v_constExpression v = v_expression v + +and v_statement v = + let k v = v_wrap v_statementbis v in + vin.kstmt (k, all_functions) v + +and v_statementbis = + function + | Compound v1 -> let v1 = v_compound v1 in () + | ExprStatement v1 -> let v1 = v_exprStatement v1 in () + | Labeled v1 -> let v1 = v_labeled v1 in () + | Selection v1 -> let v1 = v_selection v1 in () + | Iteration v1 -> let v1 = v_iteration v1 in () + | Jump v1 -> let v1 = v_jump v1 in () + | DeclStmt v1 -> let v1 = v_block_declaration v1 in () + | Try ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_compound v2 + and v3 = v_list v_handler v3 + in () + | NestedFunc v1 -> let v1 = v_func_definition v1 in () + | MacroStmt -> () + | StmtTodo -> () +and v_compound v = + let k v = v_brace (v_list v_statement_sequencable) v in + vin.kcompound (k, all_functions) v + +and v_statement_sequencable = + function + | StmtElem v1 -> let v1 = v_statement v1 in () + | CppDirectiveStmt v1 -> let v1 = v_cpp_directive v1 in () + | IfdefStmt v1 -> let v1 = v_ifdef_directive v1 in () +and v_exprStatement v = v_option v_expression v +and v_labeled = + function + | Label ((v1, v2)) -> let v1 = v_string v1 and v2 = v_statement v2 in () + | Case ((v1, v2)) -> let v1 = v_expression v1 and v2 = v_statement v2 in () + | CaseRange ((v1, v2, v3)) -> + let v1 = v_expression v1 + and v2 = v_expression v2 + and v3 = v_statement v3 + in () + | Default v1 -> let v1 = v_statement v1 in () +and v_selection = + function + | If ((v1, v2, v3, v4, v5)) -> + let v1 = v_tok v1 + and v2 = v_paren v_expression v2 + and v3 = v_statement v3 + and v4 = v_option v_tok v4 + and v5 = v_statement v5 + in () + | Switch ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_paren v_expression v2 + and v3 = v_statement v3 + in () +and v_iteration = + function + | While ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_paren v_expression v2 + and v3 = v_statement v3 + in () + | DoWhile ((v1, v2, v3, v4, v5)) -> + let v1 = v_tok v1 + and v2 = v_statement v2 + and v3 = v_tok v3 + and v4 = v_paren v_expression v4 + and v5 = v_tok v5 + in () + | For ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = + v_paren + (fun (v1, v2, v3) -> + let v1 = v_wrap v_exprStatement v1 + and v2 = v_wrap v_exprStatement v2 + and v3 = v_wrap v_exprStatement v3 + in ()) + v2 + and v3 = v_statement v3 + in () + | MacroIteration ((v1, v2, v3)) -> + let v1 = v_wrap2 v_string v1 + and v2 = v_paren (v_comma_list v_argument) v2 + and v3 = v_statement v3 + in () +and v_jump = + function + | Goto v1 -> let v1 = v_string v1 in () + | Continue -> () + | Break -> () + | Return -> () + | ReturnExpr v1 -> let v1 = v_expression v1 in () + | GotoComputed v1 -> let v1 = v_expression v1 in () +and v_handler (v1, v2, v3) = + let v1 = v_tok v1 + and v2 = v_paren v_exception_declaration v2 + and v3 = v_compound v3 + in () +and v_exception_declaration = + function + | ExnDeclEllipsis v1 -> let v1 = v_tok v1 in () + | ExnDecl v1 -> let v1 = v_parameter v1 in () +and v_block_declaration x = + let k = function + | DeclList ((v1, v2)) -> + let v1 = v_comma_list v_onedecl v1 and v2 = v_tok v2 in () + | MacroDecl ((v1, v2, v3, v4)) -> + let v1 = v_list v_tok v1 + and v2 = v_wrap2 v_string v2 + and v3 = v_paren (v_comma_list v_argument) v3 + and v4 = v_tok v4 + in () + | UsingDecl v1 -> + let v1 = + (match v1 with + | (v1, v2, v3) -> + let v1 = v_tok v1 and v2 = v_name v2 and v3 = v_tok v3 in ()) + in () + | UsingDirective ((v1, v2, v3, v4)) -> + let v1 = v_tok v1 + and v2 = v_tok v2 + and v3 = v_namespace_name v3 + and v4 = v_tok v4 + in () + | NameSpaceAlias ((v1, v2, v3, v4, v5)) -> + let v1 = v_tok v1 + and v2 = v_wrap2 v_string v2 + and v3 = v_tok v3 + and v4 = v_namespace_name v4 + and v5 = v_tok v5 + in () + | Asm ((v1, v2, v3, v4)) -> + let v1 = v_tok v1 + and v2 = v_option v_tok v2 + and v3 = v_paren v_asmbody v3 + and v4 = v_tok v4 + in () + in + vin.kblock_decl (k, all_functions) x +and + v_onedecl { v_namei = v_v_namei; v_type = v_v_type; v_storage = v_v_storage + } = + let arg = + v_option + (fun (v1, v2) -> let v1 = v_name v1 and v2 = v_option v_init v2 in ()) + v_v_namei in + let arg = v_fullType v_v_type in + let arg = v_storage v_v_storage in () +and v_storage v = v_storagebis v +and v_storagebis = + function + | NoSto -> () + | StoTypedef v1 -> v_tok v1 + | Sto v1 -> let v1 = v_wrap2 v_storageClass v1 in () +and v_storageClass = + function | Auto -> () | Static -> () | Register -> () | Extern -> () +and v_func_specifier = function | Inline -> () | Virtual -> () +and v_init = + function + | EqInit ((v1, v2)) -> let v1 = v_tok v1 and v2 = v_initialiser v2 in () + | ObjInit v1 -> let v1 = v_paren (v_comma_list v_argument) v1 in () +and v_initialiser x = + let k x = + match x with + | InitExpr v1 -> let v1 = v_expression v1 in () + | InitList v1 -> let v1 = v_brace (v_comma_list v_initialiser) v1 in () + | InitDesignators ((v1, v2, v3)) -> + let v1 = v_list v_designator v1 + and v2 = v_tok v2 + and v3 = v_initialiser v3 + in () + | InitFieldOld ((v1, v2, v3)) -> + let v1 = v_wrap2 v_string v1 + and v2 = v_tok v2 + and v3 = v_initialiser v3 + in () + | InitIndexOld ((v1, v2)) -> + let v1 = v_bracket v_expression v1 and v2 = v_initialiser v2 in () + in + vin.kinit (k, all_functions) x + +and v_designator = + function + | DesignatorField ((v1, v2)) -> + let v1 = v_tok v1 and v2 = v_wrap2 v_string v2 in () + | DesignatorIndex v1 -> let v1 = v_bracket v_expression v1 in () + | DesignatorRange v1 -> + let v1 = + v_bracket + (fun (v1, v2, v3) -> + let v1 = v_expression v1 + and v2 = v_tok v2 + and v3 = v_expression v3 + in ()) + v1 + in () +and v_asmbody (v1, v2) = + let v1 = v_list v_tok v1 and v2 = v_list (v_wrap v_colon) v2 in () +and v_colon = + function | Colon v1 -> let v1 = v_comma_list v_colon_option v1 in () +and v_colon_option v = v_wrap v_colon_optionbis v +and v_colon_optionbis = + function + | ColonMisc -> () + | ColonExpr v1 -> let v1 = v_paren v_expression v1 in () +and + v_func_definition x = + let k = function { + f_name = v_f_name; + f_type = v_f_type; + f_storage = v_f_storage; + f_body = v_f_body + } -> + let arg = v_name v_f_name in + let arg = v_functionType v_f_type in + let arg = v_storage v_f_storage in + let arg = v_compound v_f_body in () + in + vin.kfunc_def (k, all_functions) x + +and + v_functionType { + ft_ret = v_ft_ret; + ft_params = v_ft_params; + ft_dots = v_ft_dots; + ft_const = v_ft_const; + ft_throw = v_ft_throw + } = + let arg = v_fullType v_ft_ret in + let arg = v_paren (v_comma_list v_parameter) v_ft_params in + let arg = + v_option (fun (v1, v2) -> let v1 = v_tok v1 and v2 = v_tok v2 in ()) + v_ft_dots in + let arg = v_option v_tok v_ft_const in + let arg = v_option v_exn_spec v_ft_throw in + () +and + v_parameter x = + let k = function { + p_name = v_p_name; + p_type = v_p_type; + p_register = v_p_register; + p_val = v_p_val + } -> + let arg = v_option (v_wrap2 v_string) v_p_name in + let arg = v_fullType v_p_type in + let arg = v_option v_tok v_p_register in + let arg = + v_option + (fun (v1, v2) -> let v1 = v_tok v1 and v2 = v_expression v2 in ()) + v_p_val + in () + in + vin.kparameter (k, all_functions) x +and v_func_or_else = + function + | FunctionOrMethod v1 -> let v1 = v_func_definition v1 in () + | Constructor ((v1)) -> + let v1 = v_func_definition v1 in () + | Destructor v1 -> let v1 = v_func_definition v1 in () +and v_exn_spec (v1, v2) = + let v1 = v_tok v1 and v2 = v_paren (v_comma_list2 v_name) v2 in () + +and + v_class_definition x = + let k = function { + c_kind = v_c_kind; + c_name = v_c_name; + c_inherit = v_c_inherit; + c_members = v_c_members + } -> + let arg = v_wrap2 v_structUnion v_c_kind in + let arg = v_option v_ident_name v_c_name in + let arg = + v_option + (fun (v1, v2) -> + let v1 = v_tok v1 and v2 = v_comma_list v_base_clause v2 in ()) + v_c_inherit in + let arg = v_brace (v_list v_class_member_sequencable) v_c_members in () + in + vin.kclass_def (k, all_functions) x + +and v_structUnion = function | Struct -> () | Union -> () | Class -> () +and + v_base_clause { + i_name = v_i_name; + i_virtual = v_i_virtual; + i_access = v_i_access + } = + let arg = v_class_name v_i_name in + let arg = v_option v_tok v_i_virtual in + let arg = v_option (v_wrap2 v_access_spec) v_i_access in () +and v_access_spec = function | Public -> () | Private -> () | Protected -> () + +and v_method_decl = function + | ConstructorDecl ((v1, v2, v3)) -> + let v1 = v_wrap2 v_string v1 + and v2 = v_paren (v_comma_list v_parameter) v2 + and v3 = v_tok v3 in () + | DestructorDecl ((v1, v2, v3, v4, v5)) -> + let v1 = v_tok v1 + and v2 = v_wrap2 v_string v2 + and v3 = v_paren (v_option v_tok) v3 + and v4 = v_option v_exn_spec v4 + and v5 = v_tok v5 + in () + + | MethodDecl ((v1, v2, v3)) -> + let v1 = v_onedecl v1 + and v2 = + v_option (fun (v1, v2) -> let v1 = v_tok v1 and v2 = v_tok v2 in ()) + v2 + and v3 = v_tok v3 + in () + +and v_class_member x = + let k = + function + | Access ((v1, v2)) -> + let v1 = v_wrap2 v_access_spec v1 and v2 = v_tok v2 in () + | MemberField (v1, v2) -> + let v1 = (v_comma_list v_fieldkind) v1 in + let v2 = v_tok v2 in + () + | MemberFunc v1 -> let v1 = v_func_or_else v1 in () + | MemberDecl v1 -> let v1 = v_method_decl v1 in () + | QualifiedIdInClass ((v1, v2)) -> + let v1 = v_name v1 and v2 = v_tok v2 in () + | TemplateDeclInClass v1 -> + let v1 = + (match v1 with + | (v1, v2, v3) -> + let v1 = v_tok v1 + and v2 = v_template_parameters v2 + and v3 = v_declaration v3 + in ()) + in () + | UsingDeclInClass v1 -> + let v1 = + (match v1 with + | (v1, v2, v3) -> + let v1 = v_tok v1 and v2 = v_name v2 and v3 = v_tok v3 in ()) + in () + | EmptyField v1 -> let v1 = v_tok v1 in () + in + vin.kclass_member (k, all_functions) x + +and v_fieldkind x = + let k = function + | FieldDecl v1 -> let v1 = v_onedecl v1 in () + | BitField ((v1, v2, v3, v4)) -> + let v1 = v_option (v_wrap2 v_string) v1 + and v2 = v_tok v2 + and v3 = v_fullType v3 + and v4 = v_constExpression v4 + in () + in + vin.kfieldkind (k, all_functions) x + +and v_class_member_sequencable = + function + | ClassElem v1 -> let v1 = v_class_member v1 in () + | CppDirectiveStruct v1 -> let v1 = v_cpp_directive v1 in () + | IfdefStruct v1 -> let v1 = v_ifdef_directive v1 in () +and v_cpp_directive x = + let k = function + | Define ((v1, v2, v3, v4)) -> + let v1 = v_tok v1 + and v2 = v_wrap2 v_string v2 + and v3 = v_define_kind v3 + and v4 = v_define_val v4 + in () + | Include ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_inc_kind v2 + and v3 = v_string v3 + in () + | Undef v1 -> let v1 = v_wrap2 v_string v1 in () + | PragmaAndCo v1 -> let v1 = v_tok v1 in () + in + vin.kcpp (k, all_functions) x +and v_define_kind = + function + | DefineVar -> () + | DefineFunc v1 -> + let v1 = v_paren (v_comma_list (v_wrap v_string)) v1 in () +and v_define_val = + function + | DefinePrintWrapper ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_paren v_expression v2 + and v3 = v_name v3 + in () + | DefineExpr v1 -> let v1 = v_expression v1 in () + | DefineStmt v1 -> let v1 = v_statement v1 in () + | DefineType v1 -> let v1 = v_fullType v1 in () + | DefineDoWhileZero v1 -> let v1 = v_wrap v_statement v1 in () + | DefineFunction v1 -> let v1 = v_func_definition v1 in () + | DefineInit v1 -> let v1 = v_initialiser v1 in () + | DefineText v1 -> let v1 = v_wrap v_string v1 in () + | DefineEmpty -> () + | DefineTodo -> () +and v_inc_kind = + function + | Local -> () + | Standard -> () + | Weird -> () +and v_inc_elem v = v_string v +and v_ifdef_directive v = v_wrap2 v_ifdefkind v +and v_ifdefkind = + function + | Ifdef -> () + | IfdefElse -> () + | IfdefElseif -> () + | IfdefEndif -> () +and v_declaration x = + let k = function + | BlockDecl v1 -> let v1 = v_block_declaration v1 in () + | Func v1 -> let v1 = v_func_or_else v1 in () + | TemplateDecl (v1, v2, v3) -> + let v1 = v_tok v1 + and v2 = v_template_parameters v2 + and v3 = v_declaration v3 + in () + | TemplateSpecialization ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_angle v_unit v2 + and v3 = v_declaration v3 + in () + | ExternC ((v1, v2, v3)) -> + let v1 = v_tok v1 and v2 = v_tok v2 and v3 = v_declaration v3 in () + | ExternCList ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_tok v2 + and v3 = v_brace (v_list v_declaration_sequencable) v3 + in () + | NameSpace ((v1, v2, v3)) -> + let v1 = v_tok v1 + and v2 = v_wrap2 v_string v2 + and v3 = v_brace (v_list v_declaration_sequencable) v3 + in () + | NameSpaceExtend ((v1, v2)) -> + let v1 = v_string v1 and v2 = v_list v_declaration_sequencable v2 in () + | NameSpaceAnon ((v1, v2)) -> + let v1 = v_tok v1 + and v2 = v_brace (v_list v_declaration_sequencable) v2 + in () + | EmptyDef v1 -> let v1 = v_tok v1 in () + | DeclTodo -> () + in + vin.kdeclaration (k, all_functions) x + +and v_template_parameter v = v_parameter v +and v_template_parameters v = v_angle (v_comma_list v_template_parameter) v +and v_declaration_sequencable x = + let k = function + | NotParsedCorrectly v1 -> let v1 = v_list v_tok v1 in () + | DeclElem v1 -> let v1 = v_declaration v1 in () + | CppDirectiveDecl v1 -> let v1 = v_cpp_directive v1 in () + | IfdefDecl v1 -> let v1 = v_ifdef_directive v1 in () + | MacroTop ((v1, v2, v3)) -> + let v1 = v_wrap2 v_string v1 + and v2 = v_paren (v_comma_list v_argument) v2 + and v3 = v_option v_tok v3 + in () + | MacroVarTop ((v1, v2)) -> + let v1 = v_wrap2 v_string v1 and v2 = v_tok v2 in () + in + vin.ktoplevel (k, all_functions) x +and v_toplevel v = v_declaration_sequencable v +and v_program v = v_list v_toplevel v +and v_any = + function + | Program v1 -> let v1 = v_program v1 in () + | Toplevel v1 -> let v1 = v_toplevel v1 in () + | BlockDecl2 v1 -> let v1 = v_block_declaration v1 in () + | Stmt v1 -> let v1 = v_statement v1 in () + | Expr v1 -> let v1 = v_expression v1 in () + | Init v1 -> let v1 = v_initialiser v1 in () + | Type v1 -> let v1 = v_fullType v1 in () + | Name v1 -> let v1 = v_name v1 in () + | Cpp v1 -> let v1 = v_cpp_directive v1 in () + | ClassDef v1 -> let v1 = v_class_definition v1 in () + | FuncDef v1 -> let v1 = v_func_definition v1 in () + | FuncOrElse v1 -> let v1 = v_func_or_else v1 in () + | Constant v1 -> let v1 = v_constant v1 in () + | Argument v1 -> let v1 = v_argument v1 in () + | Parameter v1 -> let v1 = v_parameter v1 in () + | Body v1 -> let v1 = v_compound v1 in () + | Info v1 -> let v1 = v_info v1 in () + | InfoList v1 -> let v1 = v_list v_info v1 in () + | ClassMember v1 -> let v1 = v_class_member v1 in () + | OneDecl v1 -> let v1 = v_onedecl v1 in () + +(* end of auto generation *) + + and all_functions x = v_any x +in + v_any + + diff --git a/lang_cpp/parsing/visitor_cpp.mli b/lang_cpp/parsing/visitor_cpp.mli new file mode 100644 index 0000000..da7daa1 --- /dev/null +++ b/lang_cpp/parsing/visitor_cpp.mli @@ -0,0 +1,32 @@ + +open Ast_cpp + +(* the hooks *) +type visitor_in = { + kexpr: expression vin; + kstmt: statement vin; + kinit: initialiser vin; + ktypeC: typeC vin; + + kclass_member: class_member vin; + kfieldkind: fieldkind vin; + + kparameter: parameter vin; + kcompound: compound vin; + + kclass_def: class_definition vin; + kfunc_def: func_definition vin; + kcpp: cpp_directive vin; + kblock_decl: block_declaration vin; + + kdeclaration: declaration vin; + ktoplevel: toplevel vin; + + kinfo: tok vin; +} +and visitor_out = any -> unit +and 'a vin = ('a -> unit) * visitor_out -> 'a -> unit + +val default_visitor : visitor_in + +val mk_visitor: visitor_in -> visitor_out diff --git a/main.ml b/main.ml new file mode 100644 index 0000000..f74c950 --- /dev/null +++ b/main.ml @@ -0,0 +1,155 @@ +(* + * Please imagine a long and boring gnu-style copyright notice + * appearing just here. + *) +open Common + +(*****************************************************************************) +(* Purpose *) +(*****************************************************************************) +(* + * A "driver" for the different parsers in pfff. + *) + +(*****************************************************************************) +(* Flags *) +(*****************************************************************************) + +(* In addition to flags that can be tweaked via -xxx options (cf the + * full list of options in the "the options" section below), this + * program also depends on external files ? + *) + +let verbose = ref false + +let lang = ref "c" + +(* action mode *) +let action = ref "" + +(*****************************************************************************) +(* Some debugging functions *) +(*****************************************************************************) + +(*****************************************************************************) +(* Helpers *) +(*****************************************************************************) + +(*****************************************************************************) +(* Main action *) +(*****************************************************************************) +let main_action _xs = + raise Todo + +(*****************************************************************************) +(* Extra Actions *) +(*****************************************************************************) +let test_json_pretty_printer file = + let json = Json_in.load_json file in + let s = Json_io.string_of_json json in + pr s + + + +(* ---------------------------------------------------------------------- *) +let pfff_extra_actions () = [ + "-dump_json", " ", + Common.mk_action_1_arg test_json_pretty_printer; + "-json_pp", " ", + Common.mk_action_1_arg test_json_pretty_printer; +] + +(*****************************************************************************) +(* The options *) +(*****************************************************************************) + +let all_actions () = + pfff_extra_actions() @ + Test_parsing_c.actions()@ + Test_parsing_cpp.actions()@ + +(* + Test_analyze_cpp.actions () ++ + Test_analyze_php.actions () ++ + Test_analyze_ml.actions () ++ + Test_analyze_clang.actions () ++ + Test_analyze_c.actions() ++ +*) + [] + + +let options () = [ + "-verbose", Arg.Set verbose, + " "; + "-lang", Arg.Set_string lang, + (spf " choose language (default = %s)" !lang); + ] @ + Flag_parsing_cpp.cmdline_flags_verbose () @ + + Flag_parsing_cpp.cmdline_flags_debugging () @ + + Flag_parsing_cpp.cmdline_flags_macrofile () @ + + Common.options_of_actions action (all_actions()) @ + Common2.cmdline_flags_devel () @ + Common2.cmdline_flags_other () @ + [ + "-version", Arg.Unit (fun () -> + pr2 (spf "pfff version: %s" Config_pfff.version); + exit 0; + ), " guess what"; + ] + + +(*****************************************************************************) +(* Main entry point *) +(*****************************************************************************) + +let main () = + + Gc.set {(Gc.get ()) with Gc.stack_limit = 1000 * 1024 * 1024}; + (* Common_extra.set_link(); + let argv = Features.Distribution.mpi_adjust_argv Sys.argv in + *) + + let usage_msg = + "Usage: " ^ Common2.basename Sys.argv.(0) ^ + " [options] " ^ "\n" ^ "Options are:" + in + (* does side effect on many global flags *) + let args = Common.parse_options (options()) usage_msg Sys.argv in + + (* must be done after Arg.parse, because Common.profile is set by it *) + Common.profile_code "Main total" (fun () -> + + (match args with + + (* --------------------------------------------------------- *) + (* actions, useful to debug subpart *) + (* --------------------------------------------------------- *) + | xs when List.mem !action (Common.action_list (all_actions())) -> + Common.do_action !action xs (all_actions()) + + | _ when not (Common.null_string !action) -> + failwith ("unrecognized action or wrong params: " ^ !action) + + (* --------------------------------------------------------- *) + (* main entry *) + (* --------------------------------------------------------- *) + | x::xs -> + main_action (x::xs) + + (* --------------------------------------------------------- *) + (* empty entry *) + (* --------------------------------------------------------- *) + | [] -> + Common.usage usage_msg (options()); + failwith "too few arguments" + ) + ) + +(*****************************************************************************) +let _ = + Common.main_boilerplate (fun () -> + main (); + )