commit d7f09c9791da1be533713507806f4718e971d725 Author: Simon Cruanes Date: Thu Mar 6 10:45:04 2014 +0100 initial commit diff --git a/.depend b/.depend new file mode 100644 index 00000000..593b95a7 --- /dev/null +++ b/.depend @@ -0,0 +1,112 @@ +common/hashcons.cmo: common/hashcons.cmi +common/hashcons.cmx: common/hashcons.cmi +common/heap.cmo: common/heap.cmi +common/heap.cmx: common/heap.cmi +common/hstring.cmo: common/timer.cmi common/hashcons.cmi common/hstring.cmi +common/hstring.cmx: common/timer.cmx common/hashcons.cmx common/hstring.cmi +common/iheap.cmo: common/vec.cmi common/iheap.cmi +common/iheap.cmx: common/vec.cmx common/iheap.cmi +common/timer.cmo: common/timer.cmi +common/timer.cmx: common/timer.cmi +common/vec.cmo: common/vec.cmi +common/vec.cmx: common/vec.cmi +common/hashcons.cmi: +common/heap.cmi: +common/hstring.cmi: common/timer.cmi common/hashcons.cmi +common/iheap.cmi: +common/timer.cmi: +common/vec.cmi: +smt/arith.cmo: smt/ty.cmi smt/term.cmi smt/symbols.cmi smt/sig.cmi \ + smt/polynome.cmi smt/literal.cmi common/hstring.cmi smt/fm.cmi \ + smt/exception.cmi smt/arith.cmi +smt/arith.cmx: smt/ty.cmx smt/term.cmx smt/symbols.cmx smt/sig.cmi \ + smt/polynome.cmx smt/literal.cmx common/hstring.cmx smt/fm.cmx \ + smt/exception.cmx smt/arith.cmi +smt/cc.cmo: smt/use.cmi smt/uf.cmi smt/ty.cmi common/timer.cmi smt/term.cmi \ + smt/symbols.cmi smt/sig.cmi smt/literal.cmi common/hstring.cmi \ + smt/explanation.cmi smt/exception.cmi smt/cc.cmi +smt/cc.cmx: smt/use.cmx smt/uf.cmx smt/ty.cmx common/timer.cmx smt/term.cmx \ + smt/symbols.cmx smt/sig.cmi smt/literal.cmx common/hstring.cmx \ + smt/explanation.cmx smt/exception.cmx smt/cc.cmi +smt/combine.cmo: smt/ty.cmi smt/term.cmi smt/sum.cmi smt/sig.cmi \ + smt/polynome.cmi smt/arith.cmi smt/combine.cmi +smt/combine.cmx: smt/ty.cmx smt/term.cmx smt/sum.cmx smt/sig.cmi \ + smt/polynome.cmx smt/arith.cmx smt/combine.cmi +smt/exception.cmo: smt/explanation.cmi smt/exception.cmi +smt/exception.cmx: smt/explanation.cmx smt/exception.cmi +smt/explanation.cmo: smt/solver_types.cmi smt/explanation.cmi +smt/explanation.cmx: smt/solver_types.cmx smt/explanation.cmi +smt/fm.cmo: smt/ty.cmi smt/term.cmi smt/symbols.cmi smt/sig.cmi \ + smt/polynome.cmi smt/literal.cmi smt/intervals.cmi common/hstring.cmi \ + smt/explanation.cmi smt/exception.cmi smt/fm.cmi +smt/fm.cmx: smt/ty.cmx smt/term.cmx smt/symbols.cmx smt/sig.cmi \ + smt/polynome.cmx smt/literal.cmx smt/intervals.cmx common/hstring.cmx \ + smt/explanation.cmx smt/exception.cmx smt/fm.cmi +smt/intervals.cmo: smt/ty.cmi smt/sig.cmi smt/explanation.cmi \ + smt/intervals.cmi +smt/intervals.cmx: smt/ty.cmx smt/sig.cmi smt/explanation.cmx \ + smt/intervals.cmi +smt/literal.cmo: smt/term.cmi smt/symbols.cmi common/hstring.cmi \ + common/hashcons.cmi smt/literal.cmi +smt/literal.cmx: smt/term.cmx smt/symbols.cmx common/hstring.cmx \ + common/hashcons.cmx smt/literal.cmi +smt/polynome.cmo: smt/ty.cmi smt/term.cmi smt/polynome.cmi +smt/polynome.cmx: smt/ty.cmx smt/term.cmx smt/polynome.cmi +smt/smt.cmo: common/vec.cmi smt/ty.cmi common/timer.cmi smt/term.cmi \ + smt/symbols.cmi smt/solver_types.cmi smt/solver.cmi smt/literal.cmi \ + common/hstring.cmi smt/smt.cmi +smt/smt.cmx: common/vec.cmx smt/ty.cmx common/timer.cmx smt/term.cmx \ + smt/symbols.cmx smt/solver_types.cmx smt/solver.cmx smt/literal.cmx \ + common/hstring.cmx smt/smt.cmi +smt/solver.cmo: common/vec.cmi smt/solver_types.cmi common/iheap.cmi \ + smt/explanation.cmi smt/exception.cmi smt/combine.cmi smt/cc.cmi \ + smt/solver.cmi +smt/solver.cmx: common/vec.cmx smt/solver_types.cmx common/iheap.cmx \ + smt/explanation.cmx smt/exception.cmx smt/combine.cmx smt/cc.cmx \ + smt/solver.cmi +smt/solver_types.cmo: common/vec.cmi smt/term.cmi smt/literal.cmi \ + common/hstring.cmi smt/solver_types.cmi +smt/solver_types.cmx: common/vec.cmx smt/term.cmx smt/literal.cmx \ + common/hstring.cmx smt/solver_types.cmi +smt/sum.cmo: smt/ty.cmi smt/term.cmi smt/symbols.cmi smt/sig.cmi \ + smt/literal.cmi common/hstring.cmi smt/explanation.cmi smt/exception.cmi \ + smt/sum.cmi +smt/sum.cmx: smt/ty.cmx smt/term.cmx smt/symbols.cmx smt/sig.cmi \ + smt/literal.cmx common/hstring.cmx smt/explanation.cmx smt/exception.cmx \ + smt/sum.cmi +smt/symbols.cmo: common/hstring.cmi common/hashcons.cmi smt/symbols.cmi +smt/symbols.cmx: common/hstring.cmx common/hashcons.cmx smt/symbols.cmi +smt/term.cmo: smt/ty.cmi smt/symbols.cmi common/hashcons.cmi smt/term.cmi +smt/term.cmx: smt/ty.cmx smt/symbols.cmx common/hashcons.cmx smt/term.cmi +smt/ty.cmo: common/hstring.cmi smt/ty.cmi +smt/ty.cmx: common/hstring.cmx smt/ty.cmi +smt/uf.cmo: smt/term.cmi smt/symbols.cmi smt/sig.cmi smt/literal.cmi \ + common/hstring.cmi smt/explanation.cmi smt/exception.cmi smt/uf.cmi +smt/uf.cmx: smt/term.cmx smt/symbols.cmx smt/sig.cmi smt/literal.cmx \ + common/hstring.cmx smt/explanation.cmx smt/exception.cmx smt/uf.cmi +smt/use.cmo: smt/ty.cmi smt/term.cmi smt/symbols.cmi smt/sig.cmi \ + smt/literal.cmi common/hstring.cmi smt/explanation.cmi smt/use.cmi +smt/use.cmx: smt/ty.cmx smt/term.cmx smt/symbols.cmx smt/sig.cmi \ + smt/literal.cmx common/hstring.cmx smt/explanation.cmx smt/use.cmi +smt/arith.cmi: smt/sig.cmi smt/polynome.cmi +smt/cc.cmi: common/timer.cmi smt/term.cmi smt/sig.cmi smt/literal.cmi \ + smt/explanation.cmi +smt/combine.cmi: smt/sig.cmi +smt/exception.cmi: smt/explanation.cmi +smt/explanation.cmi: smt/solver_types.cmi +smt/fm.cmi: smt/sig.cmi smt/polynome.cmi +smt/intervals.cmi: smt/ty.cmi smt/sig.cmi smt/explanation.cmi +smt/literal.cmi: smt/term.cmi common/hstring.cmi +smt/polynome.cmi: smt/ty.cmi smt/term.cmi +smt/sig.cmi: smt/ty.cmi smt/term.cmi smt/symbols.cmi smt/literal.cmi \ + smt/explanation.cmi +smt/smt.cmi: smt/literal.cmi common/hstring.cmi +smt/solver.cmi: smt/solver_types.cmi smt/literal.cmi +smt/solver_types.cmi: common/vec.cmi smt/literal.cmi +smt/sum.cmi: smt/sig.cmi +smt/symbols.cmi: common/hstring.cmi +smt/term.cmi: smt/ty.cmi smt/symbols.cmi +smt/ty.cmi: common/hstring.cmi +smt/uf.cmi: smt/term.cmi smt/sig.cmi smt/literal.cmi smt/explanation.cmi +smt/use.cmi: smt/term.cmi smt/symbols.cmi smt/sig.cmi smt/literal.cmi \ + smt/explanation.cmi diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..79607037 --- /dev/null +++ b/.gitignore @@ -0,0 +1,13 @@ +*.annot +*.cma +*.cmi +*.cmo +*.cmx +*.cmxa +*.cmxs +*.o +*.a +*.log +*.status +Makefile +.*.swp diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 00000000..d445df88 --- /dev/null +++ b/Makefile.in @@ -0,0 +1,180 @@ +########################################################################## +# # +# Alt-Ergo Zero # +# # +# Sylvain Conchon and Alain Mebsout # +# Universite Paris-Sud 11 # +# # +# Copyright 2011. This file is distributed under the terms of the # +# Apache Software License version 2.0 # +# # +########################################################################## + +QUIET="" + +# where to install the binaries +DESTDIR= +prefix=@prefix@ +exec_prefix=@exec_prefix@ +BINDIR=$(DESTDIR)@bindir@ +LIBDIR=$(DESTDIR)@libdir@/alt-ergo-zero + +# where to install the man page +MANDIR=$(DESTDIR)@mandir@ + +# other variables set by ./configure +OCAMLC = @OCAMLC@ +OCAMLOPT = @OCAMLOPT@ +OCAMLDEP = @OCAMLDEP@ +OCAMLLEX = @OCAMLLEX@ +OCAMLYACC= @OCAMLYACC@ +OCAMLLIB = @OCAMLLIB@ +OCAMLBEST= @OCAMLBEST@ +OCAMLVERSION = @OCAMLVERSION@ +OCAMLWIN32 = @OCAMLWIN32@ +EXE = @EXE@ +LIBEXT = @LIBEXT@ +OBJEXT = @OBJEXT@ + +INCLUDES = -I common/ -I smt/ + +BFLAGS = -dtypes -g $(INCLUDES) -annot +OFLAGS = -dtypes $(INCLUDES) -annot -for-pack Aez + +BIBBYTE=nums.cma unix.cma + +BIBOPT=$(BIBBYTE:.cma=.cmxa) + +# main target +############# + +NAME = aez + +CMA = aez.cma +CMXA = aez.cmxa + +all: $(OCAMLBEST) +byte: $(CMA) +opt: $(CMA) $(CMXA) + +# bytecode and native-code compilation +###################################### + +SMTCMO = smt/exception.cmo smt/symbols.cmo \ + smt/ty.cmo smt/term.cmo smt/literal.cmo \ + smt/solver_types.cmo smt/explanation.cmo \ + smt/polynome.cmo smt/uf.cmo smt/use.cmo \ + smt/intervals.cmo smt/fm.cmo smt/arith.cmo smt/sum.cmo \ + smt/combine.cmo smt/cc.cmo smt/solver.cmo smt/smt.cmo + +COMMONCMO = common/timer.cmo common/hashcons.cmo common/hstring.cmo\ + common/vec.cmo common/heap.cmo common/iheap.cmo + +CMO = $(COMMONCMO) $(SMTCMO) + +CMX = $(CMO:.cmo=.cmx) + +$(CMA): aez.cmo + $(OCAMLC) -a $(BFLAGS) -o $@ $^ + +$(CMXA): aez.cmx + $(OCAMLOPT) -a $(OFLAGS) $(INCLUDES) -o $@ $^ + +aez.cmo: smt/smt.cmi +aez.cmo: $(CMO) + $(OCAMLC) $(BFLAGS) -pack -o $@ $(CMO) + +aez.cmx: smt/smt.cmi +aez.cmx: $(CMX) + $(OCAMLOPT) $(INCLUDES) -pack -o $@ $(CMX) + + + +# generic rules +############### + +.SUFFIXES: .mli .ml .cmi .cmo .cmx .mll .mly + +.mli.cmi: + @true compile -w a $(BFLAGS) $< + $(if $(QUIET),@echo 'Compiling $@' &&) $(OCAMLC) -c $(BFLAGS) $< + +.ml.cmo: + $(if $(QUIET),@echo 'Compiling $@' &&) $(OCAMLC) -c $(BFLAGS) $< + @true compile -w a $(BFLAGS) $< + +.ml.o: + @true compile -w a $(BFLAGS) $< + $(if $(QUIET),@echo 'Compiling $@' &&) $(OCAMLOPT) -c $(OFLAGS) $< + +.ml.cmx: + $(if $(QUIET),@echo 'Compiling $@' &&) $(OCAMLOPT) -c $(OFLAGS) $< + @true compile -w a $(BFLAGS) $< + +.mll.ml: + $(if $(QUIET),@echo 'Compiling $<' &&) $(OCAMLLEX) $< > /dev/null + +.mly.ml: + $(if $(QUIET),@echo 'Compiling $<' &&) $(OCAMLYACC) -v $< + +.mly.mli: + $(if $(QUIET),@echo 'Compiling $<' &&) $(OCAMLYACC) -v $< + +# Emacs tags +############ + +tags: + find . -name "*.ml*" | sort -r | xargs \ + etags "--regex=/let[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/let[ \t]+rec[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/and[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/type[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/exception[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/val[ \t]+\([^ \t]+\)/\1/" \ + "--regex=/module[ \t]+\([^ \t]+\)/\1/" + +# installation +############## + +INSTALL_LIBDIR=$(DESTDIR)$(OCAMLLIB)/alt-ergo-zero + +install: install-$(OCAMLBEST) + +install-byte: + mkdir -p $(INSTALL_LIBDIR) + cp -f aez.cm[iot] $(CMA) $(INSTALL_LIBDIR) + +install-opt: + mkdir -p $(INSTALL_LIBDIR) + cp -f aez.cm[iot] $(CMA) $(INSTALL_LIBDIR) + cp -f aez$(LIBEXT) aez.cmx $(CMXA) $(INSTALL_LIBDIR) + +ocamlfind-install: + ocamlfind install aez META $(BUILD)aez.cmi $(BCMA) $(BCMXA) $(BUILD)aez.a + +ocamlfind-remove: + ocamlfind remove aez + +doc: smt/smt.mli + mkdir -p $(doc) + ocamldoc -html -d doc/ -I smt -I common smt/smt.mli +####### + +clean:: + @rm -f *.cm[itox] *.cmti *.o *~ *.annot + @rm -f common/*.cm[itox] common/*.cmti common/*.o common/*~ common/*.annot + @rm -f smt/*.cm[itox] smt/*.cmti smt/*.o smt/*~ smt/*.annot + @rm -f $(GENERATED) *.output + @rm -f $(NAME).byte $(NAME).opt + +# depend +######## + +.depend depend:: $(GENERATED) + @rm -f .depend + @$(OCAMLDEP) -slash -I common/ common/*.ml common/*.mli > .depend + @$(OCAMLDEP) -I common/ -I smt/ smt/*.ml smt/*.mli >> .depend + @$(OCAMLDEP) -I common/ -I smt/ -slash *.ml *.mli >> .depend + + +include .depend diff --git a/README b/README new file mode 100644 index 00000000..4f4c7902 --- /dev/null +++ b/README @@ -0,0 +1,37 @@ +Alt-Ergo Zero is an OCaml library for an SMT solver. This SMT solver +is derived from Alt-Ergo. It uses an efficient SAT solver and supports +the following quantifier free theories: + - Equality and uninterpreted functions + - Arithmetic (linear, non-linear, integer, real) + - Enumerated data-types + +This API makes heavy use of hash consing, in particular hash-consed strings. + +COPYRIGHT +========= + +This program is distributed under the Apache Software License version +2.0. See the enclosed file COPYING. + + +INSTALLATION +============ +To compile Alt-Ergo Zero you will need OCaml version 3.11 (or newer). + +Uncompress the archive and do: + cd aez-0.3 + ./configure + make + +then with superuser rigths: + make install + + +USAGE +===== + +The documentation generated by ocamldoc is available in the repertory doc/. + +To use Alt-Ergo Zero in the toplevel you must give ocaml (or ocamlc) +the options -I +alt-ergo-zero unix.cma nums.cma aez.cma. To compile +natively you must use -I +alt-ergo-zero unix.cmxa nums.cmxa aez.cmxa. diff --git a/common/bitv.ml b/common/bitv.ml new file mode 100644 index 00000000..cfe6162d --- /dev/null +++ b/common/bitv.ml @@ -0,0 +1,762 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software 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. *) +(* *) +(**************************************************************************) + +(*i $Id: bitv.ml,v 1.26 2012/08/14 07:26:00 filliatr Exp $ i*) + +(*s Bit vectors. The interface and part of the code are borrowed from the + [Array] module of the ocaml standard library (but things are simplified + here since we can always initialize a bit vector). This module also + provides bitwise operations. *) + +(*s We represent a bit vector by a vector of integers (field [bits]), + and we keep the information of the size of the bit vector since it + can not be found out with the size of the array (field [length]). *) + +type t = { + length : int; + bits : int array } + +let length v = v.length + +(*s Each element of the array is an integer containing [bpi] bits, where + [bpi] is determined according to the machine word size. Since we do not + use the sign bit, [bpi] is 30 on a 32-bits machine and 62 on a 64-bits + machines. We maintain the following invariant: + {\em The unused bits of the last integer are always + zeros.} This is ensured by [create] and maintained in other functions + using [normalize]. [bit_j], [bit_not_j], [low_mask] and [up_mask] + are arrays used to extract and mask bits in a single integer. *) + +let bpi = Sys.word_size - 2 + +let max_length = Sys.max_array_length * bpi + +let bit_j = Array.init bpi (fun j -> 1 lsl j) +let bit_not_j = Array.init bpi (fun j -> max_int - bit_j.(j)) + +let low_mask = Array.create (succ bpi) 0 +let _ = + for i = 1 to bpi do low_mask.(i) <- low_mask.(i-1) lor bit_j.(pred i) done + +let keep_lowest_bits a j = a land low_mask.(j) + +let high_mask = Array.init (succ bpi) (fun j -> low_mask.(j) lsl (bpi-j)) + +let keep_highest_bits a j = a land high_mask.(j) + +(*s Creating and normalizing a bit vector is easy: it is just a matter of + taking care of the invariant. Copy is immediate. *) + +let create n b = + let initv = if b then max_int else 0 in + let r = n mod bpi in + if r = 0 then + { length = n; bits = Array.create (n / bpi) initv } + else begin + let s = n / bpi in + let b = Array.create (succ s) initv in + b.(s) <- b.(s) land low_mask.(r); + { length = n; bits = b } + end + +let normalize v = + let r = v.length mod bpi in + if r > 0 then + let b = v.bits in + let s = Array.length b in + b.(s-1) <- b.(s-1) land low_mask.(r) + +let copy v = { length = v.length; bits = Array.copy v.bits } + +(*s Access and assignment. The [n]th bit of a bit vector is the [j]th + bit of the [i]th integer, where [i = n / bpi] and [j = n mod + bpi]. Both [i] and [j] and computed by the function [pos]. + Accessing a bit is testing whether the result of the corresponding + mask operation is non-zero, and assigning it is done with a + bitwiwe operation: an {\em or} with [bit_j] to set it, and an {\em + and} with [bit_not_j] to unset it. *) + +let pos n = + let i = n / bpi and j = n mod bpi in + if j < 0 then (i - 1, j + bpi) else (i,j) + +let unsafe_get v n = + let (i,j) = pos n in + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 + +let unsafe_set v n b = + let (i,j) = pos n in + if b then + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) + else + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) + +(*s The corresponding safe operations test the validiy of the access. *) + +let get v n = + if n < 0 or n >= v.length then invalid_arg "Bitv.get"; + let (i,j) = pos n in + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_j j)) > 0 + +let set v n b = + if n < 0 or n >= v.length then invalid_arg "Bitv.set"; + let (i,j) = pos n in + if b then + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) lor (Array.unsafe_get bit_j j)) + else + Array.unsafe_set v.bits i + ((Array.unsafe_get v.bits i) land (Array.unsafe_get bit_not_j j)) + +(*s [init] is implemented naively using [unsafe_set]. *) + +let init n f = + let v = create n false in + for i = 0 to pred n do + unsafe_set v i (f i) + done; + v + +(*s Handling bits by packets is the key for efficiency of functions + [append], [concat], [sub] and [blit]. + We start by a very general function [blit_bits a i m v n] which blits + the bits [i] to [i+m-1] of a native integer [a] + onto the bit vector [v] at index [n]. It assumes that [i..i+m-1] and + [n..n+m-1] are respectively valid subparts of [a] and [v]. + It is optimized when the bits fit the lowest boundary of an integer + (case [j == 0]). *) + +let blit_bits a i m v n = + let (i',j) = pos n in + if j == 0 then + Array.unsafe_set v i' + ((keep_lowest_bits (a lsr i) m) lor + (keep_highest_bits (Array.unsafe_get v i') (bpi - m))) + else + let d = m + j - bpi in + if d > 0 then begin + Array.unsafe_set v i' + (((keep_lowest_bits (a lsr i) (bpi - j)) lsl j) lor + (keep_lowest_bits (Array.unsafe_get v i') j)); + Array.unsafe_set v (succ i') + ((keep_lowest_bits (a lsr (i + bpi - j)) d) lor + (keep_highest_bits (Array.unsafe_get v (succ i')) (bpi - d))) + end else + Array.unsafe_set v i' + (((keep_lowest_bits (a lsr i) m) lsl j) lor + ((Array.unsafe_get v i') land (low_mask.(j) lor high_mask.(-d)))) + +(*s [blit_int] implements [blit_bits] in the particular case when + [i=0] and [m=bpi] i.e. when we blit all the bits of [a]. *) + +let blit_int a v n = + let (i,j) = pos n in + if j == 0 then + Array.unsafe_set v i a + else begin + Array.unsafe_set v i + ( (keep_lowest_bits (Array.unsafe_get v i) j) lor + ((keep_lowest_bits a (bpi - j)) lsl j)); + Array.unsafe_set v (succ i) + ((keep_highest_bits (Array.unsafe_get v (succ i)) (bpi - j)) lor + (a lsr (bpi - j))) + end + +(*s When blitting a subpart of a bit vector into another bit vector, there + are two possible cases: (1) all the bits are contained in a single integer + of the first bit vector, and a single call to [blit_bits] is the + only thing to do, or (2) the source bits overlap on several integers of + the source array, and then we do a loop of [blit_int], with two calls + to [blit_bits] for the two bounds. *) + +let unsafe_blit v1 ofs1 v2 ofs2 len = + if len > 0 then + let (bi,bj) = pos ofs1 in + let (ei,ej) = pos (ofs1 + len - 1) in + if bi == ei then + blit_bits (Array.unsafe_get v1 bi) bj len v2 ofs2 + else begin + blit_bits (Array.unsafe_get v1 bi) bj (bpi - bj) v2 ofs2; + let n = ref (ofs2 + bpi - bj) in + for i = succ bi to pred ei do + blit_int (Array.unsafe_get v1 i) v2 !n; + n := !n + bpi + done; + blit_bits (Array.unsafe_get v1 ei) 0 (succ ej) v2 !n + end + +let blit v1 ofs1 v2 ofs2 len = + if len < 0 or ofs1 < 0 or ofs1 + len > v1.length + or ofs2 < 0 or ofs2 + len > v2.length + then invalid_arg "Bitv.blit"; + unsafe_blit v1.bits ofs1 v2.bits ofs2 len + +(*s Extracting the subvector [ofs..ofs+len-1] of [v] is just creating a + new vector of length [len] and blitting the subvector of [v] inside. *) + +let sub v ofs len = + if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.sub"; + let r = create len false in + unsafe_blit v.bits ofs r.bits 0 len; + r + +(*s The concatenation of two bit vectors [v1] and [v2] is obtained by + creating a vector for the result and blitting inside the two vectors. + [v1] is copied directly. *) + +let append v1 v2 = + let l1 = v1.length + and l2 = v2.length in + let r = create (l1 + l2) false in + let b1 = v1.bits in + let b2 = v2.bits in + let b = r.bits in + for i = 0 to Array.length b1 - 1 do + Array.unsafe_set b i (Array.unsafe_get b1 i) + done; + unsafe_blit b2 0 b l1 l2; + r + +(*s The concatenation of a list of bit vectors is obtained by iterating + [unsafe_blit]. *) + +let concat vl = + let size = List.fold_left (fun sz v -> sz + v.length) 0 vl in + let res = create size false in + let b = res.bits in + let pos = ref 0 in + List.iter + (fun v -> + let n = v.length in + unsafe_blit v.bits 0 b !pos n; + pos := !pos + n) + vl; + res + +(*s Filling is a particular case of blitting with a source made of all + ones or all zeros. Thus we instanciate [unsafe_blit], with 0 and + [max_int]. *) + +let blit_zeros v ofs len = + if len > 0 then + let (bi,bj) = pos ofs in + let (ei,ej) = pos (ofs + len - 1) in + if bi == ei then + blit_bits 0 bj len v ofs + else begin + blit_bits 0 bj (bpi - bj) v ofs; + let n = ref (ofs + bpi - bj) in + for i = succ bi to pred ei do + blit_int 0 v !n; + n := !n + bpi + done; + blit_bits 0 0 (succ ej) v !n + end + +let blit_ones v ofs len = + if len > 0 then + let (bi,bj) = pos ofs in + let (ei,ej) = pos (ofs + len - 1) in + if bi == ei then + blit_bits max_int bj len v ofs + else begin + blit_bits max_int bj (bpi - bj) v ofs; + let n = ref (ofs + bpi - bj) in + for i = succ bi to pred ei do + blit_int max_int v !n; + n := !n + bpi + done; + blit_bits max_int 0 (succ ej) v !n + end + +let fill v ofs len b = + if ofs < 0 or len < 0 or ofs + len > v.length then invalid_arg "Bitv.fill"; + if b then blit_ones v.bits ofs len else blit_zeros v.bits ofs len + +(*s All the iterators are implemented as for traditional arrays, using + [unsafe_get]. For [iter] and [map], we do not precompute [(f + true)] and [(f false)] since [f] is likely to have + side-effects. *) + +let iter f v = + for i = 0 to v.length - 1 do f (unsafe_get v i) done + +let map f v = + let l = v.length in + let r = create l false in + for i = 0 to l - 1 do + unsafe_set r i (f (unsafe_get v i)) + done; + r + +let iteri f v = + for i = 0 to v.length - 1 do f i (unsafe_get v i) done + +let mapi f v = + let l = v.length in + let r = create l false in + for i = 0 to l - 1 do + unsafe_set r i (f i (unsafe_get v i)) + done; + r + +let fold_left f x v = + let r = ref x in + for i = 0 to v.length - 1 do + r := f !r (unsafe_get v i) + done; + !r + +let fold_right f v x = + let r = ref x in + for i = v.length - 1 downto 0 do + r := f (unsafe_get v i) !r + done; + !r + +let foldi_left f x v = + let r = ref x in + for i = 0 to v.length - 1 do + r := f !r i (unsafe_get v i) + done; + !r + +let foldi_right f v x = + let r = ref x in + for i = v.length - 1 downto 0 do + r := f i (unsafe_get v i) !r + done; + !r + +let iteri_true_naive f v = + Array.iteri + (fun i n -> if n != 0 then begin + let i_bpi = i * bpi in + for j = 0 to bpi - 1 do + if n land (Array.unsafe_get bit_j j) > 0 then f (i_bpi + j) + done + end) + v.bits + +(*s Number of trailing zeros (on a 32-bit machine) *) + +let hash32 x = ((0x34ca8b09 * x) land 0x3fffffff) lsr 24 +let ntz_arr32 = Array.create 64 0 +let () = for i = 0 to 30 do ntz_arr32.(hash32 (1 lsl i)) <- i done +let ntz32 x = if x == 0 then 31 else ntz_arr32.(hash32 (x land (-x))) + +let iteri_true_ntz32 f v = + Array.iteri + (fun i n -> + let i_bpi = i * bpi in + let rec visit x = + if x != 0 then begin + let b = x land (-x) in + f (i_bpi + ntz32 b); + visit (x - b) + end + in + visit n) + v.bits + +let martin_constant = (0x03f79d71b lsl 28) lor 0x4ca8b09 (*0x03f79d71b4ca8b09*) +let hash64 x = ((martin_constant * x) land max_int) lsr 56 +let ntz_arr64 = Array.create 64 0 +let () = for i = 0 to 62 do ntz_arr64.(hash64 (1 lsl i)) <- i done +let ntz64 x = if x == 0 then 63 else ntz_arr64.(hash64 (x land (-x))) + +let iteri_true_ntz64 f v = + Array.iteri + (fun i n -> + let i_bpi = i * bpi in + let rec visit x = + if x != 0 then begin + let b = x land (-x) in + f (i_bpi + ntz64 b); + visit (x - b) + end + in + visit n) + v.bits + +let iteri_true = match Sys.word_size with + | 32 -> iteri_true_ntz32 + | 64 -> iteri_true_ntz64 + | _ -> assert false + +(*s Bitwise operations. It is straigthforward, since bitwise operations + can be realized by the corresponding bitwise operations over integers. + However, one has to take care of normalizing the result of [bwnot] + which introduces ones in highest significant positions. *) + +let bw_and v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_and"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) land b2.(i) + done; + { length = l; bits = a } + +let bw_and_in_place v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_and"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + for i = 0 to n - 1 do + b1.(i) <- b1.(i) land b2.(i) + done + +let bw_or v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_or"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) lor b2.(i) + done; + { length = l; bits = a } + +let bw_or_in_place v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_or"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + for i = 0 to n - 1 do + b1.(i) <- b1.(i) lor b2.(i) + done + +let bw_xor v1 v2 = + let l = v1.length in + if l <> v2.length then invalid_arg "Bitv.bw_xor"; + let b1 = v1.bits + and b2 = v2.bits in + let n = Array.length b1 in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- b1.(i) lxor b2.(i) + done; + { length = l; bits = a } + +let bw_not v = + let b = v.bits in + let n = Array.length b in + let a = Array.create n 0 in + for i = 0 to n - 1 do + a.(i) <- max_int land (lnot b.(i)) + done; + let r = { length = v.length; bits = a } in + normalize r; + r + +let bw_not_in_place v = + let b = v.bits in + let n = Array.length b in + for i = 0 to n - 1 do + b.(i) <- max_int land (lnot b.(i)) + done; + normalize v + +(*s Shift operations. It is easy to reuse [unsafe_blit], although it is + probably slightly less efficient than a ad-hoc piece of code. *) + +let rec shiftl v d = + if d == 0 then + copy v + else if d < 0 then + shiftr v (-d) + else begin + let n = v.length in + let r = create n false in + if d < n then unsafe_blit v.bits 0 r.bits d (n - d); + r + end + +and shiftr v d = + if d == 0 then + copy v + else if d < 0 then + shiftl v (-d) + else begin + let n = v.length in + let r = create n false in + if d < n then unsafe_blit v.bits d r.bits 0 (n - d); + r + end + +(*s Testing for all zeros and all ones. *) + +let all_zeros v = + let b = v.bits in + let n = Array.length b in + let rec test i = + (i == n) || ((Array.unsafe_get b i == 0) && test (succ i)) + in + test 0 + +let all_ones v = + let b = v.bits in + let n = Array.length b in + let rec test i = + if i == n - 1 then + let m = v.length mod bpi in + (Array.unsafe_get b i) == (if m == 0 then max_int else low_mask.(m)) + else + ((Array.unsafe_get b i) == max_int) && test (succ i) + in + test 0 + +(*s Conversions to and from strings. *) + +module S(I : sig val least_first : bool end) = struct + + let to_string v = + let n = v.length in + let s = String.make n '0' in + for i = 0 to n - 1 do + if unsafe_get v i then s.[if I.least_first then i else n-1-i] <- '1' + done; + s + + let print fmt v = Format.pp_print_string fmt (to_string v) + + let of_string s = + let n = String.length s in + let v = create n false in + for i = 0 to n - 1 do + let c = String.unsafe_get s i in + if c = '1' then + unsafe_set v (if I.least_first then i else n-1-i) true + else + if c <> '0' then invalid_arg "Bitv.of_string" + done; + v + +end +module L = S(struct let least_first = true end) +module M = S(struct let least_first = false end) + +(*s Input/output in a machine-independent format. *) + +let output_bin out_ch v = + let len = length v in + let rec loop i pow byte = + let byte = if unsafe_get v i then byte lor pow else byte in + if i = len - 1 then + output_byte out_ch byte + else if i mod 8 = 7 then begin + output_byte out_ch byte; + loop (i + 1) 1 0 + end else + loop (i + 1) (pow * 2) byte + in + output_binary_int out_ch len; + if len > 0 then loop 0 1 0 + +let input_bin in_ch = + let len = input_binary_int in_ch in + let bits = create len false in + let rec loop i byte = + if i < len then begin + let byte = if i mod 8 = 0 then input_byte in_ch else byte in + if byte land 1 = 1 then unsafe_set bits i true; + loop (i+1) (byte / 2) + end + in + if len > 0 then loop 0 0; + bits + +(*s Iteration on all bit vectors of length [n] using a Gray code. *) + +let first_set v n = + let rec lookup i = + if i = n then raise Not_found ; + if unsafe_get v i then i else lookup (i + 1) + in + lookup 0 + +let gray_iter f n = + let bv = create n false in + let rec iter () = + f bv; + unsafe_set bv 0 (not (unsafe_get bv 0)); + f bv; + let pos = succ (first_set bv n) in + if pos < n then begin + unsafe_set bv pos (not (unsafe_get bv pos)); + iter () + end + in + if n > 0 then iter () + + +(*s Coercions to/from lists of integers *) + +let of_list l = + let n = List.fold_left max 0 l in + let b = create (succ n) false in + let add_element i = + (* negative numbers are invalid *) + if i < 0 then invalid_arg "Bitv.of_list"; + unsafe_set b i true + in + List.iter add_element l; + b + +let of_list_with_length l len = + let b = create len false in + let add_element i = + if i < 0 || i >= len then invalid_arg "Bitv.of_list_with_length"; + unsafe_set b i true + in + List.iter add_element l; + b + +let to_list b = + let n = length b in + let rec make i acc = + if i < 0 then acc + else make (pred i) (if unsafe_get b i then i :: acc else acc) + in + make (pred n) [] + + +(*s To/from integers. *) + +(* [int] *) +let of_int_us i = + { length = bpi; bits = [| i land max_int |] } +let to_int_us v = + if v.length < bpi then invalid_arg "Bitv.to_int_us"; + v.bits.(0) + +let of_int_s i = + { length = succ bpi; bits = [| i land max_int; (i lsr bpi) land 1 |] } +let to_int_s v = + if v.length < succ bpi then invalid_arg "Bitv.to_int_s"; + v.bits.(0) lor (v.bits.(1) lsl bpi) + +(* [Int32] *) +let of_int32_us i = match Sys.word_size with + | 32 -> { length = 31; + bits = [| (Int32.to_int i) land max_int; + let hi = Int32.shift_right_logical i 30 in + (Int32.to_int hi) land 1 |] } + | 64 -> { length = 31; bits = [| (Int32.to_int i) land 0x7fffffff |] } + | _ -> assert false +let to_int32_us v = + if v.length < 31 then invalid_arg "Bitv.to_int32_us"; + match Sys.word_size with + | 32 -> + Int32.logor (Int32.of_int v.bits.(0)) + (Int32.shift_left (Int32.of_int (v.bits.(1) land 1)) 30) + | 64 -> + Int32.of_int (v.bits.(0) land 0x7fffffff) + | _ -> assert false + +(* this is 0xffffffff (ocaml >= 3.08 checks for literal overflow) *) +let ffffffff = (0xffff lsl 16) lor 0xffff + +let of_int32_s i = match Sys.word_size with + | 32 -> { length = 32; + bits = [| (Int32.to_int i) land max_int; + let hi = Int32.shift_right_logical i 30 in + (Int32.to_int hi) land 3 |] } + | 64 -> { length = 32; bits = [| (Int32.to_int i) land ffffffff |] } + | _ -> assert false +let to_int32_s v = + if v.length < 32 then invalid_arg "Bitv.to_int32_s"; + match Sys.word_size with + | 32 -> + Int32.logor (Int32.of_int v.bits.(0)) + (Int32.shift_left (Int32.of_int (v.bits.(1) land 3)) 30) + | 64 -> + Int32.of_int (v.bits.(0) land ffffffff) + | _ -> assert false + +(* [Int64] *) +let of_int64_us i = match Sys.word_size with + | 32 -> { length = 63; + bits = [| (Int64.to_int i) land max_int; + (let mi = Int64.shift_right_logical i 30 in + (Int64.to_int mi) land max_int); + let hi = Int64.shift_right_logical i 60 in + (Int64.to_int hi) land 1 |] } + | 64 -> { length = 63; + bits = [| (Int64.to_int i) land max_int; + let hi = Int64.shift_right_logical i 62 in + (Int64.to_int hi) land 1 |] } + | _ -> assert false +let to_int64_us v = + if v.length < 63 then invalid_arg "Bitv.to_int64_us"; + match Sys.word_size with + | 32 -> + Int64.logor (Int64.of_int v.bits.(0)) + (Int64.logor (Int64.shift_left (Int64.of_int v.bits.(1)) 30) + (Int64.shift_left (Int64.of_int (v.bits.(2) land 7)) 60)) + | 64 -> + Int64.logor (Int64.of_int v.bits.(0)) + (Int64.shift_left (Int64.of_int (v.bits.(1) land 1)) 62) + | _ -> + assert false + +let of_int64_s i = match Sys.word_size with + | 32 -> { length = 64; + bits = [| (Int64.to_int i) land max_int; + (let mi = Int64.shift_right_logical i 30 in + (Int64.to_int mi) land max_int); + let hi = Int64.shift_right_logical i 60 in + (Int64.to_int hi) land 3 |] } + | 64 -> { length = 64; + bits = [| (Int64.to_int i) land max_int; + let hi = Int64.shift_right_logical i 62 in + (Int64.to_int hi) land 3 |] } + | _ -> assert false +let to_int64_s v = + if v.length < 64 then invalid_arg "Bitv.to_int64_s"; + match Sys.word_size with + | 32 -> + Int64.logor (Int64.of_int v.bits.(0)) + (Int64.logor (Int64.shift_left (Int64.of_int v.bits.(1)) 30) + (Int64.shift_left (Int64.of_int (v.bits.(2) land 15)) 60)) + | 64 -> + Int64.logor (Int64.of_int v.bits.(0)) + (Int64.shift_left (Int64.of_int (v.bits.(1) land 3)) 62) + | _ -> assert false + +(* [Nativeint] *) +let select_of f32 f64 = match Sys.word_size with + | 32 -> (fun i -> f32 (Nativeint.to_int32 i)) + | 64 -> (fun i -> f64 (Int64.of_nativeint i)) + | _ -> assert false +let of_nativeint_s = select_of of_int32_s of_int64_s +let of_nativeint_us = select_of of_int32_us of_int64_us +let select_to f32 f64 = match Sys.word_size with + | 32 -> (fun i -> Nativeint.of_int32 (f32 i)) + | 64 -> (fun i -> Int64.to_nativeint (f64 i)) + | _ -> assert false +let to_nativeint_s = select_to to_int32_s to_int64_s +let to_nativeint_us = select_to to_int32_us to_int64_us + + diff --git a/common/bitv.mli b/common/bitv.mli new file mode 100644 index 00000000..4d513927 --- /dev/null +++ b/common/bitv.mli @@ -0,0 +1,228 @@ +(**************************************************************************) +(* *) +(* Copyright (C) Jean-Christophe Filliatre *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software 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. *) +(* *) +(**************************************************************************) + +(*i $Id: bitv.mli,v 1.19 2012/08/14 07:26:00 filliatr Exp $ i*) + +(*s {\bf Module Bitv}. + This module implements bit vectors, as an abstract datatype [t]. + Since bit vectors are particular cases of arrays, this module provides + the same operations as module [Array] (Sections~\ref{barray} + up to \ref{earray}). It also provides bitwise operations + (Section~\ref{bitwise}) and conversions to/from integer types. + + In the following, [false] stands for bit 0 and [true] for bit 1. *) + +type t + +(*s {\bf Creation, access and assignment.} \label{barray} + [(Bitv.create n b)] creates a new bit vector of length [n], + initialized with [b]. + [(Bitv.init n f)] returns a fresh vector of length [n], + with bit number [i] initialized to the result of [(f i)]. + [(Bitv.set v n b)] sets the [n]th bit of [v] to the value [b]. + [(Bitv.get v n)] returns the [n]th bit of [v]. + [Bitv.length] returns the length (number of elements) of the given + vector. *) + +val create : int -> bool -> t + +val init : int -> (int -> bool) -> t + +val set : t -> int -> bool -> unit + +val get : t -> int -> bool + +val length : t -> int + +(*s [max_length] is the maximum length of a bit vector (System dependent). *) + +val max_length : int + +(*s {\bf Copies and concatenations.} + [(Bitv.copy v)] returns a copy of [v], + that is, a fresh vector containing the same elements as + [v]. [(Bitv.append v1 v2)] returns a fresh vector containing the + concatenation of the vectors [v1] and [v2]. [Bitv.concat] is + similar to [Bitv.append], but catenates a list of vectors. *) + +val copy : t -> t + +val append : t -> t -> t + +val concat : t list -> t + +(*s {\bf Sub-vectors and filling.} + [(Bitv.sub v start len)] returns a fresh + vector of length [len], containing the bits number [start] to + [start + len - 1] of vector [v]. Raise [Invalid_argument + "Bitv.sub"] if [start] and [len] do not designate a valid + subvector of [v]; that is, if [start < 0], or [len < 0], or [start + + len > Bitv.length a]. + + [(Bitv.fill v ofs len b)] modifies the vector [v] in place, + storing [b] in elements number [ofs] to [ofs + len - 1]. Raise + [Invalid_argument "Bitv.fill"] if [ofs] and [len] do not designate + a valid subvector of [v]. + + [(Bitv.blit v1 o1 v2 o2 len)] copies [len] elements from vector + [v1], starting at element number [o1], to vector [v2], starting at + element number [o2]. It {\em does not work} correctly if [v1] and [v2] are + the same vector with the source and destination chunks overlapping. + Raise [Invalid_argument "Bitv.blit"] if [o1] and [len] do not + designate a valid subvector of [v1], or if [o2] and [len] do not + designate a valid subvector of [v2]. *) + +val sub : t -> int -> int -> t + +val fill : t -> int -> int -> bool -> unit + +val blit : t -> int -> t -> int -> int -> unit + +(*s {\bf Iterators.} \label{earray} + [(Bitv.iter f v)] applies function [f] in turn to all + the elements of [v]. Given a function [f], [(Bitv.map f v)] applies + [f] to all + the elements of [v], and builds a vector with the results returned + by [f]. [Bitv.iteri] and [Bitv.mapi] are similar to [Bitv.iter] + and [Bitv.map] respectively, but the function is applied to the + index of the element as first argument, and the element itself as + second argument. + + [(Bitv.fold_left f x v)] computes [f (... (f (f x (get v 0)) (get + v 1)) ...) (get v (n-1))], where [n] is the length of the vector + [v]. + + [(Bitv.fold_right f a x)] computes [f (get v 0) (f (get v 1) + ( ... (f (get v (n-1)) x) ...))], where [n] is the length of the + vector [v]. *) + +val iter : (bool -> unit) -> t -> unit +val map : (bool -> bool) -> t -> t + +val iteri : (int -> bool -> unit) -> t -> unit +val mapi : (int -> bool -> bool) -> t -> t + +val fold_left : ('a -> bool -> 'a) -> 'a -> t -> 'a +val fold_right : (bool -> 'a -> 'a) -> t -> 'a -> 'a +val foldi_left : ('a -> int -> bool -> 'a) -> 'a -> t -> 'a +val foldi_right : (int -> bool -> 'a -> 'a) -> t -> 'a -> 'a + +(*s [iteri_true f v] applies function [f] in turn to all indexes of + the elements of [v] which are set (i.e. [true]); indexes are + visited from least significant to most significant. *) + +val iteri_true : (int -> unit) -> t -> unit + +(*s [gray_iter f n] iterates function [f] on all bit vectors + of length [n], once each, using a Gray code. The order in which + bit vectors are processed is unspecified. *) + +val gray_iter : (t -> unit) -> int -> unit + +(*s {\bf Bitwise operations.} \label{bitwise} [bwand], [bwor] and + [bwxor] implement logical and, or and exclusive or. They return + fresh vectors and raise [Invalid_argument "Bitv.xxx"] if the two + vectors do not have the same length (where \texttt{xxx} is the + name of the function). [bwnot] implements the logical negation. + It returns a fresh vector. + [shiftl] and [shiftr] implement shifts. They return fresh vectors. + [shiftl] moves bits from least to most significant, and [shiftr] + from most to least significant (think [lsl] and [lsr]). + [all_zeros] and [all_ones] respectively test for a vector only + containing zeros and only containing ones. *) + +val bw_and : t -> t -> t +val bw_or : t -> t -> t +val bw_xor : t -> t -> t +val bw_not : t -> t + +val bw_and_in_place : t -> t -> unit +val bw_or_in_place : t -> t -> unit +val bw_not_in_place : t -> unit + +val shiftl : t -> int -> t +val shiftr : t -> int -> t + +val all_zeros : t -> bool +val all_ones : t -> bool + +(*s {\bf Conversions to and from strings.} *) + +(* With least significant bits first. *) + +module L : sig + val to_string : t -> string + val of_string : string -> t + val print : Format.formatter -> t -> unit +end + +(* With most significant bits first. *) + +module M : sig + val to_string : t -> string + val of_string : string -> t + val print : Format.formatter -> t -> unit +end + +(*s {\bf Input/output in a machine-independent format.} + The following functions export/import a bit vector to/from a channel, + in a way that is compact, independent of the machine architecture, and + independent of the OCaml version. + For a bit vector of length [n], the number of bytes of this external + representation is 4+ceil(n/8) on a 32-bit machine and 8+ceil(n/8) on + a 64-bit machine. *) + +val output_bin: out_channel -> t -> unit +val input_bin: in_channel -> t + +(*s {\bf Conversions to and from lists of integers.} + The list gives the indices of bits which are set (ie [true]). *) + +val to_list : t -> int list +val of_list : int list -> t +val of_list_with_length : int list -> int -> t + +(*s Interpretation of bit vectors as integers. Least significant bit + comes first (ie is at index 0 in the bit vector). + [to_xxx] functions truncate when the bit vector is too wide, + and raise [Invalid_argument] when it is too short. + Suffix [_s] means that sign bit is kept, + and [_us] that it is discarded. *) + +(* type [int] (length 31/63 with sign, 30/62 without) *) +val of_int_s : int -> t +val to_int_s : t -> int +val of_int_us : int -> t +val to_int_us : t -> int +(* type [Int32.t] (length 32 with sign, 31 without) *) +val of_int32_s : Int32.t -> t +val to_int32_s : t -> Int32.t +val of_int32_us : Int32.t -> t +val to_int32_us : t -> Int32.t +(* type [Int64.t] (length 64 with sign, 63 without) *) +val of_int64_s : Int64.t -> t +val to_int64_s : t -> Int64.t +val of_int64_us : Int64.t -> t +val to_int64_us : t -> Int64.t +(* type [Nativeint.t] (length 32/64 with sign, 31/63 without) *) +val of_nativeint_s : Nativeint.t -> t +val to_nativeint_s : t -> Nativeint.t +val of_nativeint_us : Nativeint.t -> t +val to_nativeint_us : t -> Nativeint.t + +(*s Only if you know what you are doing... *) + +val unsafe_set : t -> int -> bool -> unit +val unsafe_get : t -> int -> bool diff --git a/common/hashcons.ml b/common/hashcons.ml new file mode 100644 index 00000000..1d44e929 --- /dev/null +++ b/common/hashcons.ml @@ -0,0 +1,97 @@ +(**************************************************************************) +(* *) +(* Copyright (C) 2010- *) +(* François Bobot *) +(* Jean-Christophe Filliâtre *) +(* Claude Marché *) +(* Andrei Paskevich *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software 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. *) +(* *) +(**************************************************************************) + +(*s Hash tables for hash-consing. (Some code is borrowed from the ocaml + standard library, which is copyright 1996 INRIA.) *) + +module type HashedType = + sig + type t + val equal : t -> t -> bool + val hash : t -> int + val tag : int -> t -> t + end + +module type S = + sig + type t + val hashcons : t -> t + val iter : (t -> unit) -> unit + val stats : unit -> int * int * int * int * int * int + end + +module Make(H : HashedType) : (S with type t = H.t) = +struct + type t = H.t + + module WH = Weak.Make (H) + + let next_tag = ref 0 + + let htable = WH.create 5003 + + let hashcons d = + let d = H.tag !next_tag d in + let o = WH.merge htable d in + if o == d then incr next_tag; + o + + let iter f = WH.iter f htable + + let stats () = WH.stats htable +end + +let combine acc n = n * 65599 + acc +let combine2 acc n1 n2 = combine acc (combine n1 n2) +let combine3 acc n1 n2 n3 = combine acc (combine n1 (combine n2 n3)) +let combine_list f = List.fold_left (fun acc x -> combine acc (f x)) +let combine_option h = function None -> 0 | Some s -> (h s) + 1 +let combine_pair h1 h2 (a1,a2) = combine (h1 a1) (h2 a2) + +type 'a hash_consed = { + tag : int; + node : 'a } + +module type HashedType_consed = + sig + type t + val equal : t -> t -> bool + val hash : t -> int + end + +module type S_consed = + sig + type key + val hashcons : key -> key hash_consed + val iter : (key hash_consed -> unit) -> unit + val stats : unit -> int * int * int * int * int * int + end + +module Make_consed(H : HashedType_consed) : (S_consed with type key = H.t) = +struct + module M = Make(struct + type t = H.t hash_consed + let hash x = H.hash x.node + let equal x y = H.equal x.node y.node + let tag i x = {x with tag = i} + end) + include M + type key = H.t + let hashcons x = M.hashcons {tag = -1; node = x} +end diff --git a/common/hashcons.mli b/common/hashcons.mli new file mode 100644 index 00000000..f000e407 --- /dev/null +++ b/common/hashcons.mli @@ -0,0 +1,109 @@ +(**************************************************************************) +(* *) +(* Copyright (C) 2010- *) +(* François Bobot *) +(* Jean-Christophe Filliâtre *) +(* Claude Marché *) +(* Andrei Paskevich *) +(* *) +(* This software is free software; you can redistribute it and/or *) +(* modify it under the terms of the GNU Library General Public *) +(* License version 2.1, with the special exception on linking *) +(* described in file LICENSE. *) +(* *) +(* This software 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. *) +(* *) +(**************************************************************************) + +(** Hash tables for hash consing *) + +(*s Hash tables for hash consing. + + Hash consed values are of the + following type [hash_consed]. The field [tag] contains a unique + integer (for values hash consed with the same table). The field + [hkey] contains the hash key of the value (without modulo) for + possible use in other hash tables (and internally when hash + consing tables are resized). The field [node] contains the value + itself. + + Hash consing tables are using weak pointers, so that values that are no + more referenced from anywhere else can be erased by the GC. *) + +module type HashedType = + sig + type t + val equal : t -> t -> bool + val hash : t -> int + val tag : int -> t -> t + end + +module type S = + sig + type t + + val hashcons : t -> t + (** [hashcons n f] hash-cons the value [n] using function [f] i.e. returns + any existing value in the table equal to [n], if any; + otherwise, creates a new value with function [f], stores it + in the table and returns it. Function [f] is passed + the node [n] as first argument and the unique id as second argument. + *) + + val iter : (t -> unit) -> unit + (** [iter f] iterates [f] over all elements of the table . *) + val stats : unit -> int * int * int * int * int * int + (** Return statistics on the table. The numbers are, in order: + table length, number of entries, sum of bucket lengths, + smallest bucket length, median bucket length, biggest + bucket length. *) + end + +module Make(H : HashedType) : (S with type t = H.t) + + +(* helpers *) + +val combine : int -> int -> int +val combine2 : int -> int -> int -> int +val combine3 : int -> int -> int -> int -> int +val combine_list : ('a -> int) -> int -> 'a list -> int +val combine_option : ('a -> int) -> 'a option -> int +val combine_pair : ('a -> int) -> ('b -> int) -> 'a * 'b -> int + +(* For simple use *) +type 'a hash_consed = private { + tag : int; + node : 'a } + +module type HashedType_consed = + sig + type t + val equal : t -> t -> bool + val hash : t -> int + end + +module type S_consed = + sig + type key + + val hashcons : key -> key hash_consed + (** [hashcons n f] hash-cons the value [n] using function [f] i.e. returns + any existing value in the table equal to [n], if any; + otherwise, creates a new value with function [f], stores it + in the table and returns it. Function [f] is passed + the node [n] as first argument and the unique id as second argument. + *) + + val iter : (key hash_consed -> unit) -> unit + (** [iter f] iterates [f] over all elements of the table . *) + val stats : unit -> int * int * int * int * int * int + (** Return statistics on the table. The numbers are, in order: + table length, number of entries, sum of bucket lengths, + smallest bucket length, median bucket length, biggest + bucket length. *) + end + +module Make_consed(H : HashedType_consed) : (S_consed with type key = H.t) diff --git a/common/heap.ml b/common/heap.ml new file mode 100644 index 00000000..ac93b9b4 --- /dev/null +++ b/common/heap.ml @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +exception EmptyHeap + +module type OrderType = sig + type t + + val compare : t -> t -> int +end + +module type S = sig + type t + type elem + + val empty : t + val pop : t -> elem * t + val add : t -> elem list -> t + val elements : t -> elem list +end + + +module Make ( X : OrderType ) = struct + + type elem = X.t + type t = Empty | Node of elem * t * t + + let empty = Empty + + let rec fusion t1 t2 = + match t1, t2 with + | _ , Empty -> t1 + | Empty , _ -> t2 + | Node (m1, g1, d1), Node (m2, g2, d2) -> + if X.compare m1 m2 <= 0 then Node (m1, d1, fusion g1 t2) + else Node (m2, d2, fusion g2 t1) + + let pop = function + | Empty -> raise EmptyHeap + | Node(m, g, d) -> m, fusion g d + + let add h l = + List.fold_left (fun h x -> fusion (Node(x, Empty, Empty)) h ) h l + + let elements h = + let rec elements_aux acc = function + | Empty -> acc + | Node (m1 ,g1 ,d1) -> elements_aux (m1 :: acc) (fusion g1 d1) + in + elements_aux [] h + +end diff --git a/common/heap.mli b/common/heap.mli new file mode 100644 index 00000000..0a52ec3c --- /dev/null +++ b/common/heap.mli @@ -0,0 +1,32 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +exception EmptyHeap + +module type OrderType = sig + type t + + val compare : t -> t -> int +end + +module type S = sig + type t + type elem + + val empty : t + val pop : t -> elem * t + val add : t -> elem list -> t + val elements : t -> elem list +end + +module Make ( X : OrderType ) : S with type elem = X.t diff --git a/common/hstring.ml b/common/hstring.ml new file mode 100644 index 00000000..88a342b2 --- /dev/null +++ b/common/hstring.ml @@ -0,0 +1,91 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Hashcons + +module S = + Hashcons.Make_consed(struct include String + let hash = Hashtbl.hash + let equal = (=) end) + +module HS = struct + + type t = string Hashcons.hash_consed + + let make s = S.hashcons s + + let view s = s.node + + let equal s1 s2 = s1.tag = s2.tag + + let compare s1 s2 = compare s1.tag s2.tag + + let hash s = s.tag + + let empty = make "" + + let rec list_assoc x = function + | [] -> raise Not_found + | (y, v) :: l -> if equal x y then v else list_assoc x l + + let rec list_mem_assoc x = function + | [] -> false + | (y, _) :: l -> compare x y = 0 || list_mem_assoc x l + + let rec list_mem x = function + | [] -> false + | y :: l -> compare x y = 0 || list_mem x l + + let compare_couple (x1,y1) (x2,y2) = + let c = compare x1 x2 in + if c <> 0 then c + else compare y1 y2 + + let rec compare_list l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | x::r1, y::r2 -> + let c = compare x y in + if c <> 0 then c + else compare_list r1 r2 + + let rec list_mem_couple c = function + | [] -> false + | d :: l -> compare_couple c d = 0 || list_mem_couple c l + + let print fmt s = + Format.fprintf fmt "%s" (view s) + +end + +include HS + +module H = Hashtbl.Make(HS) + +module HSet = Set.Make(HS) + +module HMap = Map.Make(HS) + +(* struct *) +(* include Hashtbl.Make(HS) *) + +(* let find x h = *) +(* TimeHS.start (); *) +(* try *) +(* let r = find x h in *) +(* TimeHS.pause (); *) +(* r *) +(* with Not_found -> TimeHS.pause (); raise Not_found *) +(* end *) diff --git a/common/hstring.mli b/common/hstring.mli new file mode 100644 index 00000000..78937bd9 --- /dev/null +++ b/common/hstring.mli @@ -0,0 +1,78 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +(** {b Hash-consed strings} + + Hash-consing is a technique to share values that are structurally + equal. More details on + {{:http://en.wikipedia.org/wiki/Hash_consing} Wikipedia} and + {{:http://www.lri.fr/~filliatr/ftp/publis/hash-consing2.pdf} here}. + + This module provides an easy way to use hash-consing for strings. +*) + +open Hashcons + +type t = string hash_consed +(** The type of Hash-consed string *) + +val make : string -> t +(** [make s] builds ans returns a hash-consed string from [s].*) + +val view : t -> string +(** [view hs] returns the string corresponding to [hs].*) + +val equal : t -> t -> bool +(** [equal x y] returns [true] if [x] and [y] are the same hash-consed string + (constant time).*) + +val compare : t -> t -> int +(** [compares x y] returns [0] if [x] and [y] are equal, and is unspecified + otherwise but provides a total ordering on hash-consed strings.*) + +val hash : t -> int +(** [hash x] returns the integer (hash) associated to [x].*) + +val empty : t +(** the empty ([""]) hash-consed string.*) + +val list_assoc : t -> (t * 'a) list -> 'a +(** [list_assoc x l] returns the element associated with [x] in the list of + pairs [l]. + @raise Not_found if there is no value associated with [x] in the list [l].*) + +val list_mem_assoc : t -> (t * 'a) list -> bool +(** Same as {! list_assoc}, but simply returns [true] if a binding exists, and + [false] if no bindings exist for the given key.*) + +val list_mem : t -> t list -> bool +(** [list_mem x l] is [true] if and only if [x] is equal to an element of [l].*) + +val list_mem_couple : t * t -> (t * t) list -> bool +(** [list_mem_couple (x,y) l] is [true] if and only if [(x,y)] is equal to an + element of [l].*) + +val compare_list : t list -> t list -> int +(** [compare_list l1 l2] returns [0] if and only if [l1] is equal to [l2].*) + +val print : Format.formatter -> t -> unit +(** Prints a list of hash-consed strings on a formatter. *) + +module H : Hashtbl.S with type key = t +(** Hash-tables indexed by hash-consed strings *) + +module HSet : Set.S with type elt = t +(** Sets of hash-consed strings *) + +module HMap : Map.S with type key = t +(** Maps indexed by hash-consed strings *) diff --git a/common/iheap.ml b/common/iheap.ml new file mode 100644 index 00000000..5fed4910 --- /dev/null +++ b/common/iheap.ml @@ -0,0 +1,132 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type t = {heap : int Vec.t; indices : int Vec.t } + +let dummy = -100 + +let init sz = + { heap = Vec.init sz (fun i -> i) dummy; + indices = Vec.init sz (fun i -> i) dummy} + +let left i = (i lsl 1) + 1 (* i*2 + 1 *) +let right i = (i + 1) lsl 1 (* (i+1)*2 *) +let parent i = (i - 1) asr 1 (* (i-1) / 2 *) + +(* +let rec heap_property cmp ({heap=heap} as s) i = + i >= (Vec.size heap) || + ((i = 0 || not(cmp (Vec. get heap i) (Vec.get heap (parent i)))) + && heap_property cmp s (left i) && heap_property cmp s (right i)) + +let heap_property cmp s = heap_property cmp s 1 +*) + +let percolate_up cmp {heap=heap;indices=indices} i = + let x = Vec.get heap i in + let pi = ref (parent i) in + let i = ref i in + while !i <> 0 && cmp x (Vec.get heap !pi) do + Vec.set heap !i (Vec.get heap !pi); + Vec.set indices (Vec.get heap !i) !i; + i := !pi; + pi := parent !i + done; + Vec.set heap !i x; + Vec.set indices x !i + +let percolate_down cmp {heap=heap;indices=indices} i = + let x = Vec.get heap i in + let sz = Vec.size heap in + let li = ref (left i) in + let ri = ref (right i) in + let i = ref i in + (try + while !li < sz do + let child = + if !ri < sz && cmp (Vec.get heap !ri) (Vec.get heap !li) then !ri + else !li + in + if not (cmp (Vec.get heap child) x) then raise Exit; + Vec.set heap !i (Vec.get heap child); + Vec.set indices (Vec.get heap !i) !i; + i := child; + li := left !i; + ri := right !i + done; + with Exit -> ()); + Vec.set heap !i x; + Vec.set indices x !i + +let in_heap s n = n < Vec.size s.indices && Vec.get s.indices n >= 0 + +let decrease cmp s n = + assert (in_heap s n); percolate_up cmp s (Vec.get s.indices n) + +let increase cmp s n = + assert (in_heap s n); percolate_down cmp s (Vec.get s.indices n) + +let filter s filt cmp = + let j = ref 0 in + let lim = Vec.size s.heap in + for i = 0 to lim - 1 do + if filt (Vec.get s.heap i) then begin + Vec.set s.heap !j (Vec.get s.heap i); + Vec.set s.indices (Vec.get s.heap i) !j; + incr j; + end + else Vec.set s.indices (Vec.get s.heap i) (-1); + done; + Vec.shrink s.heap (lim - !j); + for i = (lim / 2) - 1 downto 0 do + percolate_down cmp s i + done + +let size s = Vec.size s.heap + +let is_empty s = Vec.is_empty s.heap + +let insert cmp s n = + if not (in_heap s n) then + begin + Vec.set s.indices n (Vec.size s.heap); + Vec.push s.heap n; + percolate_up cmp s (Vec.get s.indices n) + end + +let grow_to_by_double s sz = + Vec.grow_to_by_double s.indices sz; + Vec.grow_to_by_double s.heap sz + +(* +let update cmp s n = + assert (heap_property cmp s); + begin + if in_heap s n then + begin + percolate_up cmp s (Vec.get s.indices n); + percolate_down cmp s (Vec.get s.indices n) + end + else insert cmp s n + end; + assert (heap_property cmp s) +*) + +let remove_min cmp ({heap=heap; indices=indices} as s) = + let x = Vec.get heap 0 in + Vec.set heap 0 (Vec.last heap); (*heap.last()*) + Vec.set indices (Vec.get heap 0) 0; + Vec.set indices x (-1); + Vec.pop s.heap; + if Vec.size s.heap > 1 then percolate_down cmp s 0; + x diff --git a/common/iheap.mli b/common/iheap.mli new file mode 100644 index 00000000..dbbea23f --- /dev/null +++ b/common/iheap.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type t + +val init : int -> t +val in_heap : t -> int -> bool +val decrease : (int -> int -> bool) -> t -> int -> unit +(*val increase : (int -> int -> bool) -> t -> int -> unit*) +val size : t -> int +val is_empty : t -> bool +val insert : (int -> int -> bool) -> t -> int -> unit +val grow_to_by_double: t -> int -> unit +(*val update : (int -> int -> bool) -> t -> int -> unit*) +val remove_min : (int -> int -> bool) -> t -> int +val filter : t -> (int -> bool) -> (int -> int -> bool) -> unit diff --git a/common/timer.ml b/common/timer.ml new file mode 100644 index 00000000..8f3e9a2f --- /dev/null +++ b/common/timer.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module type S = sig + val start : unit -> unit + val pause : unit -> unit + val get : unit -> float +end + +module Make (X : sig end) = struct + + open Unix + + let u = ref 0.0 + + let cpt = ref 0.0 + + let start () = u:=(times()).tms_utime + + let pause () = cpt := !cpt +. ((times()).tms_utime -. !u) + + let get () = + !cpt + +end diff --git a/common/timer.mli b/common/timer.mli new file mode 100644 index 00000000..775be40b --- /dev/null +++ b/common/timer.mli @@ -0,0 +1,20 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module type S = sig + val start : unit -> unit + val pause : unit -> unit + val get : unit -> float +end + +module Make (X : sig end) : S diff --git a/common/vec.ml b/common/vec.ml new file mode 100644 index 00000000..4ac1af97 --- /dev/null +++ b/common/vec.ml @@ -0,0 +1,137 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type 'a t = { mutable dummy: 'a; mutable data : 'a array; mutable sz : int } + +let make capa d = {data = Array.make capa d; sz = 0; dummy = d} + +let init capa f d = {data = Array.init capa (fun i -> f i); sz = capa; dummy = d} + +let from_array data sz d = {data = data; sz = sz; dummy = d} + +let from_list l sz d = + let l = ref l in + let f_init i = match !l with [] -> assert false | e::r -> l := r; e in + {data = Array.init sz f_init; sz = sz; dummy = d} + +let clear s = s.sz <- 0 + +let shrink t i = assert (i >= 0 && i<=t.sz); t.sz <- t.sz - i + +let pop t = assert (t.sz >=1); t.sz <- t.sz - 1 + +let size t = t.sz + +let is_empty t = t.sz = 0 + +let grow_to t new_capa = + let data = t.data in + let capa = Array.length data in + t.data <- Array.init new_capa (fun i -> if i < capa then data.(i) else t.dummy) + +let grow_to_double_size t = grow_to t (2* Array.length t.data) + +let rec grow_to_by_double t new_capa = + let data = t.data in + let capa = ref (Array.length data + 1) in + while !capa < new_capa do capa := 2 * !capa done; + grow_to t !capa + + +let is_full t = Array.length t.data = t.sz + +let push t e = + (*Format.eprintf "push; sz = %d et capa=%d@." t.sz (Array.length t.data);*) + if is_full t then grow_to_double_size t; + t.data.(t.sz) <- e; + t.sz <- t.sz + 1 + +let push_none t = + if is_full t then grow_to_double_size t; + t.data.(t.sz) <- t.dummy; + t.sz <- t.sz + 1 + +let last t = + let e = t.data.(t.sz - 1) in + assert (not (e == t.dummy)); + e + +let get t i = + assert (i < t.sz); + let e = t.data.(i) in + if e == t.dummy then raise Not_found + else e + +let set t i v = + t.data.(i) <- v; + t.sz <- max t.sz (i + 1) + +let set_size t sz = t.sz <- sz + +let copy t = + let data = t.data in + let len = Array.length data in + let data = Array.init len (fun i -> data.(i)) in + { data=data; sz=t.sz; dummy = t.dummy } + +let move_to t t' = + let data = t.data in + let len = Array.length data in + let data = Array.init len (fun i -> data.(i)) in + t'.data <- data; + t'.sz <- t.sz + + +let remove t e = + let j = ref 0 in + while (!j < t.sz && not (t.data.(!j) == e)) do incr j done; + assert (!j < t.sz); + for i = !j to t.sz - 2 do t.data.(i) <- t.data.(i+1) done; + pop t + + +let fast_remove t e = + let j = ref 0 in + while (!j < t.sz && not (t.data.(!j) == e)) do incr j done; + assert (!j < t.sz); + t.data.(!j) <- last t; + pop t + + +let sort t f = + let sub_arr = Array.sub t.data 0 t.sz in + Array.fast_sort f sub_arr; + t.data <- sub_arr + +(* +template +static inline void remove(V& ts, const T& t) +{ + int j = 0; + for (; j < ts.size() && ts[j] != t; j++); + assert(j < ts.size()); + ts[j] = ts.last(); + ts.pop(); +} +#endif + +template +static inline bool find(V& ts, const T& t) +{ + int j = 0; + for (; j < ts.size() && ts[j] != t; j++); + return j < ts.size(); +} + +#endif +*) diff --git a/common/vec.mli b/common/vec.mli new file mode 100644 index 00000000..feb4d6cd --- /dev/null +++ b/common/vec.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type 'a t = { mutable dummy: 'a; mutable data : 'a array; mutable sz : int } +val make : int -> 'a -> 'a t +val init : int -> (int -> 'a) -> 'a -> 'a t +val from_array : 'a array -> int -> 'a -> 'a t +val from_list : 'a list -> int -> 'a -> 'a t +val clear : 'a t -> unit +val shrink : 'a t -> int -> unit +val pop : 'a t -> unit +val size : 'a t -> int +val is_empty : 'a t -> bool +val grow_to : 'a t -> int -> unit +val grow_to_double_size : 'a t -> unit +val grow_to_by_double : 'a t -> int -> unit +val is_full : 'a t -> bool +val push : 'a t -> 'a -> unit +val push_none : 'a t -> unit +val last : 'a t -> 'a +val get : 'a t -> int -> 'a +val set : 'a t -> int -> 'a -> unit +val set_size : 'a t -> int -> unit +val copy : 'a t -> 'a t +val move_to : 'a t -> 'a t -> unit +val remove : 'a t -> 'a -> unit +val fast_remove : 'a t -> 'a -> unit +val sort : 'a t -> ('a -> 'a -> int) -> unit diff --git a/configure b/configure new file mode 100755 index 00000000..babe673d --- /dev/null +++ b/configure @@ -0,0 +1,3097 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.69. +# +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 &1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME= +PACKAGE_TARNAME= +PACKAGE_VERSION= +PACKAGE_STRING= +PACKAGE_BUGREPORT= +PACKAGE_URL= + +ac_unique_file="smt/smt.mli" +ac_subst_vars='LTLIBOBJS +LIBOBJS +OBJEXT +LIBEXT +EXE +OCAMLWIN32 +FUNCTORYLIB +ALTERGOLIB +OCAMLLIB +OCAMLVERSION +OCAMLBEST +OCAMLYACC +OCAMLLEX +OCAMLDEP +OCAMLOPT +OCAMLC +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +' + ac_precious_vars='build_alias +host_alias +target_alias' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures this package to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF +_ACEOF +fi + +if test -n "$ac_init_help"; then + + cat <<\_ACEOF + +Report bugs to the package provider. +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +configure +generated by GNU Autoconf 2.69 + +Copyright (C) 2012 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + +for ac_prog in ocp-ocamlc.opt ocamlc.opt +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLC"; then + ac_cv_prog_OCAMLC="$OCAMLC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_OCAMLC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +OCAMLC=$ac_cv_prog_OCAMLC +if test -n "$OCAMLC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLC" >&5 +$as_echo "$OCAMLC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$OCAMLC" && break +done +test -n "$OCAMLC" || OCAMLC="no" + +if test "$OCAMLC" = no ; then + as_fn_error $? "Cannot find ocamlc." "$LINENO" 5 +fi + +OCAMLVERSION=`$OCAMLC -version` +echo "ocaml version is $OCAMLVERSION" +OCAMLLIB=`$OCAMLC -where` +echo "ocaml library path is $OCAMLLIB" + +for ac_prog in ocp-ocamlopt.opt ocamlopt.opt +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLOPT+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLOPT"; then + ac_cv_prog_OCAMLOPT="$OCAMLOPT" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_OCAMLOPT="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +OCAMLOPT=$ac_cv_prog_OCAMLOPT +if test -n "$OCAMLOPT"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLOPT" >&5 +$as_echo "$OCAMLOPT" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$OCAMLOPT" && break +done +test -n "$OCAMLOPT" || OCAMLOPT="no" + +OCAMLBEST=byte +if test "$OCAMLOPT" = no ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Cannot find ocamlopt; bytecode compilation only." >&5 +$as_echo "$as_me: WARNING: Cannot find ocamlopt; bytecode compilation only." >&2;} +else + OCAMLBEST=opt +fi + +# Extract the first word of "ocamldep", so it can be a program name with args. +set dummy ocamldep; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLDEP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLDEP"; then + ac_cv_prog_OCAMLDEP="$OCAMLDEP" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_OCAMLDEP="ocamldep" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLDEP" && ac_cv_prog_OCAMLDEP="no" +fi +fi +OCAMLDEP=$ac_cv_prog_OCAMLDEP +if test -n "$OCAMLDEP"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLDEP" >&5 +$as_echo "$OCAMLDEP" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLDEP" = no ; then + as_fn_error $? "Cannot find ocamldep." "$LINENO" 5 +fi + +# Extract the first word of "ocamllex", so it can be a program name with args. +set dummy ocamllex; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLLEX+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLLEX"; then + ac_cv_prog_OCAMLLEX="$OCAMLLEX" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_OCAMLLEX="ocamllex" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLLEX" && ac_cv_prog_OCAMLLEX="no" +fi +fi +OCAMLLEX=$ac_cv_prog_OCAMLLEX +if test -n "$OCAMLLEX"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLLEX" >&5 +$as_echo "$OCAMLLEX" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLLEX" = no ; then + as_fn_error $? "Cannot find ocamllex." "$LINENO" 5 +fi + +# Extract the first word of "ocamlyacc", so it can be a program name with args. +set dummy ocamlyacc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_OCAMLYACC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$OCAMLYACC"; then + ac_cv_prog_OCAMLYACC="$OCAMLYACC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_OCAMLYACC="ocamlyacc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_OCAMLYACC" && ac_cv_prog_OCAMLYACC="no" +fi +fi +OCAMLYACC=$ac_cv_prog_OCAMLYACC +if test -n "$OCAMLYACC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $OCAMLYACC" >&5 +$as_echo "$OCAMLYACC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +if test "$OCAMLYACC" = no ; then + as_fn_error $? "Cannot find ocamlyacc." "$LINENO" 5 +fi + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking platform" >&5 +$as_echo_n "checking platform... " >&6; } +if echo "let _ = Sys.os_type" | ocaml | grep -q Win32; then + echo "Windows platform" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Win32" >&5 +$as_echo "Win32" >&6; } + OCAMLWIN32=yes + EXE=.exe + LIBEXT=.lib + OBJEXT=.obj +else + echo "Unix platform" + OCAMLWIN32=no + EXE= + LIBEXT=.a + OBJEXT=.o +fi + + + + + + + + + + + + + + + + +ac_config_files="$ac_config_files Makefile" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +# +# If the first sed substitution is executed (which looks for macros that +# take arguments), then branch to the quote section. Otherwise, +# look for a macro that doesn't take arguments. +ac_script=' +:mline +/\\$/{ + N + s,\\\n,, + b mline +} +t clear +:clear +s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g +t quote +s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g +t quote +b any +:quote +s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g +s/\[/\\&/g +s/\]/\\&/g +s/\$/$$/g +H +:any +${ + g + s/^\n// + s/\n/ /g + p +} +' +DEFS=`sed -n "$ac_script" confdefs.h` + + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + +Configuration files: +$config_files + +Report bugs to the package provider." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +config.status +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2012 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h | --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' >$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + + +eval set X " :F $CONFIG_FILES " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + +chmod a-w Makefile diff --git a/configure.in b/configure.in new file mode 100644 index 00000000..b267b6e6 --- /dev/null +++ b/configure.in @@ -0,0 +1,81 @@ +########################################################################## +# # +# Cubicle # +# Combining model checking algorithms and SMT solvers # +# # +# Sylvain Conchon and Alain Mebsout # +# Universite Paris-Sud 11 # +# # +# Copyright 2011. This file is distributed under the terms of the # +# Apache Software License version 2.0 # +# # +########################################################################## + +AC_INIT(smt/smt.mli) + +AC_CHECK_PROGS(OCAMLC,ocp-ocamlc.opt ocamlc.opt,no) +if test "$OCAMLC" = no ; then + AC_MSG_ERROR(Cannot find ocamlc.) +fi + +OCAMLVERSION=`$OCAMLC -version` +echo "ocaml version is $OCAMLVERSION" +OCAMLLIB=`$OCAMLC -where` +echo "ocaml library path is $OCAMLLIB" + +AC_CHECK_PROGS(OCAMLOPT,ocp-ocamlopt.opt ocamlopt.opt,no) +OCAMLBEST=byte +if test "$OCAMLOPT" = no ; then + AC_MSG_WARN(Cannot find ocamlopt; bytecode compilation only.) +else + OCAMLBEST=opt +fi + +AC_CHECK_PROG(OCAMLDEP,ocamldep,ocamldep,no) +if test "$OCAMLDEP" = no ; then + AC_MSG_ERROR(Cannot find ocamldep.) +fi + +AC_CHECK_PROG(OCAMLLEX,ocamllex,ocamllex,no) +if test "$OCAMLLEX" = no ; then + AC_MSG_ERROR(Cannot find ocamllex.) +fi + +AC_CHECK_PROG(OCAMLYACC,ocamlyacc,ocamlyacc,no) +if test "$OCAMLYACC" = no ; then + AC_MSG_ERROR(Cannot find ocamlyacc.) +fi + +AC_MSG_CHECKING(platform) +if echo "let _ = Sys.os_type" | ocaml | grep -q Win32; then + echo "Windows platform" + AC_MSG_RESULT(Win32) + OCAMLWIN32=yes + EXE=.exe + LIBEXT=.lib + OBJEXT=.obj +else + echo "Unix platform" + OCAMLWIN32=no + EXE= + LIBEXT=.a + OBJEXT=.o +fi + +AC_SUBST(OCAMLC) +AC_SUBST(OCAMLOPT) +AC_SUBST(OCAMLDEP) +AC_SUBST(OCAMLLEX) +AC_SUBST(OCAMLYACC) +AC_SUBST(OCAMLBEST) +AC_SUBST(OCAMLVERSION) +AC_SUBST(OCAMLLIB) +AC_SUBST(ALTERGOLIB) +AC_SUBST(FUNCTORYLIB) +AC_SUBST(OCAMLWIN32) +AC_SUBST(EXE) +AC_SUBST(LIBEXT) +AC_SUBST(OBJEXT) + +AC_OUTPUT(Makefile) +chmod a-w Makefile diff --git a/doc/Hstring.H.html b/doc/Hstring.H.html new file mode 100644 index 00000000..5161eb26 --- /dev/null +++ b/doc/Hstring.H.html @@ -0,0 +1,25 @@ + + + + + + + + + + + + + + +Hstring.H + + +
 Up + Next +
+

Module Hstring.H

+
+
module H: Hashtbl.S  with type key = t
Hash-tables indexed by hash-consed strings
+
+ \ No newline at end of file diff --git a/doc/Hstring.HMap.html b/doc/Hstring.HMap.html new file mode 100644 index 00000000..f2cc7f21 --- /dev/null +++ b/doc/Hstring.HMap.html @@ -0,0 +1,25 @@ + + + + + + + + + + + + + + +Hstring.HMap + + +
Previous + Up + 
+

Module Hstring.HMap

+
+
module HMap: Map.S  with type key = t
Maps indexed by hash-consed strings
+
+ \ No newline at end of file diff --git a/doc/Hstring.HSet.html b/doc/Hstring.HSet.html new file mode 100644 index 00000000..7cd6a12a --- /dev/null +++ b/doc/Hstring.HSet.html @@ -0,0 +1,27 @@ + + + + + + + + + + + + + + + +Hstring.HSet + + +
Previous + Up + Next +
+

Module Hstring.HSet

+
+
module HSet: Set.S  with type elt = t
Sets of hash-consed strings
+
+ \ No newline at end of file diff --git a/doc/Hstring.html b/doc/Hstring.html new file mode 100644 index 00000000..c107def9 --- /dev/null +++ b/doc/Hstring.html @@ -0,0 +1,90 @@ + + + + + + + + + + + + + + +Hstring + + +
Previous + Up + 
+

Module Hstring

+
+
module Hstring: sig .. end
Hash-consed strings +

+ + Hash-consing is a technique to share values that are structurally + equal. More details on + Wikipedia and + here. +

+ + This module provides an easy way to use hash-consing for strings.
+

+
type t = string Hashcons.hash_consed
+
+The type of Hash-consed string
+
+ +
val make : string -> t
+make s builds ans returns a hash-consed string from s.
+
+
val view : t -> string
+view hs returns the string corresponding to hs.
+
+
val equal : t -> t -> bool
+equal x y returns true if x and y are the same hash-consed string + (constant time).
+
+
val compare : t -> t -> int
+compares x y returns 0 if x and y are equal, and is unspecified + otherwise but provides a total ordering on hash-consed strings.
+
+
val hash : t -> int
+hash x returns the integer (hash) associated to x.
+
+
val empty : t
+the empty ("") hash-consed string.
+
+
val list_assoc : t -> (t * 'a) list -> 'a
+list_assoc x l returns the element associated with x in the list of + pairs l.
+Raises Not_found if there is no value associated with x in the list l.
+
+
val list_mem_assoc : t -> (t * 'a) list -> bool
+Same as Hstring.list_assoc, but simply returns true if a binding exists, and + false if no bindings exist for the given key.
+
+
val list_mem : t -> t list -> bool
+list_mem x l is true if and only if x is equal to an element of l.
+
+
val list_mem_couple : t * t -> (t * t) list -> bool
+list_mem_couple (x,y) l is true if and only if (x,y) is equal to an + element of l.
+
+
val compare_list : t list -> t list -> int
+compare_list l1 l2 returns 0 if and only if l1 is equal to l2.
+
+
val print : Format.formatter -> t -> unit
+Prints a list of hash-consed strings on a formatter.
+
+
module H: Hashtbl.S  with type key = t
+Hash-tables indexed by hash-consed strings +
+
module HSet: Set.S  with type elt = t
+Sets of hash-consed strings +
+
module HMap: Map.S  with type key = t
+Maps indexed by hash-consed strings +
+ \ No newline at end of file diff --git a/doc/Smt.Formula.html b/doc/Smt.Formula.html new file mode 100644 index 00000000..3fe0f295 --- /dev/null +++ b/doc/Smt.Formula.html @@ -0,0 +1,135 @@ + + + + + + + + + + + + + + + +Smt.Formula + + +
Previous + Up + Next +
+

Module Smt.Formula

+
+
module Formula: sig .. end
+
type comparator = + + + + + + + + + + + + + + + + + + + +
+| +Eq(*equality (=)*)
+| +Neq(*disequality (<>)*)
+| +Le(*inequality (<=)*)
+| +Lt(*strict inequality (<)*)
+ +
+The type of comparators:
+
+ +
type combinator = + + + + + + + + + + + + + + + + + + + +
+| +And(*conjunction*)
+| +Or(*disjunction*)
+| +Imp(*implication*)
+| +Not(*negation*)
+ +
+The type of operators
+
+ +
type t = + + + + + + + + + +
+| +Lit of Literal.LT.t
+| +Comb of combinator * t list
+ +
+The type of ground formulas
+
+ +
val f_true : t
+The formula which represents true
+
+
val f_false : t
+The formula which represents false
+
+
val make_lit : comparator -> Smt.Term.t list -> t
+make_lit cmp [t1; t2] creates the literal (t1 <cmp> t2).
+
+
val make : combinator -> t list -> t
+make cmb [f_1; ...; f_n] creates the formula + (f_1 <cmb> ... <cmb> f_n).
+
+
val make_cnf : t -> Literal.LT.t list list
+make_cnf f returns a conjunctive normal form of f under the form: a + list (which is a conjunction) of lists (which are disjunctions) of + literals.
+
+
val print : Format.formatter -> t -> unit
+print fmt f prints the formula on the formatter fmt.
+
+ \ No newline at end of file diff --git a/doc/Smt.Make.html b/doc/Smt.Make.html new file mode 100644 index 00000000..3a7a58a9 --- /dev/null +++ b/doc/Smt.Make.html @@ -0,0 +1,105 @@ + + + + + + + + + + + + + + + + +Smt.Make + + +
Previous + Up + 
+

Functor Smt.Make

+
+
module Make: 
functor (Dummy : sig
end) -> Solver
Functor to create several instances of the solver
+ + + + + +
Parameters: + + + + +
+Dummy:sig end +
+
+
+
+This SMT solver is imperative in the sense that it maintains a global + context. To create different instances of Alt-Ergo Zero use the + functor Smt.Make. +

+ + A typical use of this solver is to do the following :

      clear ();
+      assume f_1;
+      ...
+      assume f_n;
+      check ();

+
type state
+
+The type of the internal state of the solver (see Smt.Solver.save_state and + Smt.Solver.restore_state).
+
+ +
+

Profiling functions


+
val get_time : unit -> float
+get_time () returns the cumulated time spent in the solver in seconds.
+
+
val get_calls : unit -> int
+get_calls () returns the cumulated number of calls to Smt.Solver.check.
+
+
+

Main API of the solver


+
val clear : unit -> unit
+clear () clears the context of the solver. Use this after Smt.Solver.check + raised Smt.Unsat or if you want to restart the solver.
+
+
val assume : ?profiling:bool -> id:int -> Smt.Formula.t -> unit
+assume ~profiling:b f id adds the formula f to the context of the + solver with idetifier id. + This function only performs unit propagation.
+
+
profiling : if set to true then profiling information (time) will + be computed (expensive because of system calls). +

+ + Raises Smt.Unsat if the context becomes inconsistent after unit + propagation.

+
val check : ?profiling:bool -> unit -> unit
+check () runs Alt-Ergo Zero on its context. If () is + returned then the context is satifiable.
+
+
profiling : if set to true then profiling information (time) will + be computed (expensive because of system calls). +

+ + Raises Smt.Unsat [id_1; ...; id_n] if the context is unsatisfiable. + id_1, ..., id_n is the unsat core (returned as the identifiers of the + formulas given to the solver).

+
val save_state : unit -> state
+save_state () returns a copy of the current state of the solver.
+
+
val restore_state : state -> unit
+restore_state s restores a previously saved state s.
+
+
val entails : ?profiling:bool -> id:int -> Smt.Formula.t -> bool
+entails ~id f returns true if the context of the solver entails + the formula f. It doesn't modify the context of the solver (the state + is saved when this function is called and restored on exit).
+
+ \ No newline at end of file diff --git a/doc/Smt.Solver.html b/doc/Smt.Solver.html new file mode 100644 index 00000000..ec9ceb5e --- /dev/null +++ b/doc/Smt.Solver.html @@ -0,0 +1,88 @@ + + + + + + + + + + + + + + + +Smt.Solver + + +
 Up + 
+

Module type Smt.Solver

+
+
module type Solver = sig .. end
+
+This SMT solver is imperative in the sense that it maintains a global + context. To create different instances of Alt-Ergo Zero use the + functor Smt.Make. +

+ + A typical use of this solver is to do the following :

      clear ();
+      assume f_1;
+      ...
+      assume f_n;
+      check ();

+
type state
+
+The type of the internal state of the solver (see Smt.Solver.save_state and + Smt.Solver.restore_state).
+
+ +
+

Profiling functions


+
val get_time : unit -> float
+get_time () returns the cumulated time spent in the solver in seconds.
+
+
val get_calls : unit -> int
+get_calls () returns the cumulated number of calls to Smt.Solver.check.
+
+
+

Main API of the solver


+
val clear : unit -> unit
+clear () clears the context of the solver. Use this after Smt.Solver.check + raised Smt.Unsat or if you want to restart the solver.
+
+
val assume : ?profiling:bool -> id:int -> Smt.Formula.t -> unit
+assume ~profiling:b f id adds the formula f to the context of the + solver with idetifier id. + This function only performs unit propagation.
+
+
profiling : if set to true then profiling information (time) will + be computed (expensive because of system calls). +

+ + Raises Smt.Unsat if the context becomes inconsistent after unit + propagation.

+
val check : ?profiling:bool -> unit -> unit
+check () runs Alt-Ergo Zero on its context. If () is + returned then the context is satifiable.
+
+
profiling : if set to true then profiling information (time) will + be computed (expensive because of system calls). +

+ + Raises Smt.Unsat [id_1; ...; id_n] if the context is unsatisfiable. + id_1, ..., id_n is the unsat core (returned as the identifiers of the + formulas given to the solver).

+
val save_state : unit -> state
+save_state () returns a copy of the current state of the solver.
+
+
val restore_state : state -> unit
+restore_state s restores a previously saved state s.
+
+
val entails : ?profiling:bool -> id:int -> Smt.Formula.t -> bool
+entails ~id f returns true if the context of the solver entails + the formula f. It doesn't modify the context of the solver (the state + is saved when this function is called and restored on exit).
+
+ \ No newline at end of file diff --git a/doc/Smt.Symbol.html b/doc/Smt.Symbol.html new file mode 100644 index 00000000..64eea377 --- /dev/null +++ b/doc/Smt.Symbol.html @@ -0,0 +1,49 @@ + + + + + + + + + + + + + + + +Smt.Symbol + + +
Previous + Up + Next +
+

Module Smt.Symbol

+
+
module Symbol: sig .. end

Function symbols


+
+
type t = Hstring.t
+
+The type of function symbols
+
+ +
val declare : Hstring.t -> Smt.Type.t list -> Smt.Type.t -> unit
+declare s [arg_1; ... ; arg_n] out declares a new function + symbol with type (arg_1, ... , arg_n) -> out
+
+
val type_of : t -> Smt.Type.t list * Smt.Type.t
+type_of x returns the type of x.
+
+
val has_abstract_type : t -> bool
+has_abstract_type x is true if the type of x is abstract.
+
+
val has_type_proc : t -> bool
+has_type_proc x is true if x has the type of a process + identifier.
+
+
val declared : t -> bool
+declared x is true if x is already declared.
+
+ \ No newline at end of file diff --git a/doc/Smt.Term.html b/doc/Smt.Term.html new file mode 100644 index 00000000..974b7ccf --- /dev/null +++ b/doc/Smt.Term.html @@ -0,0 +1,100 @@ + + + + + + + + + + + + + + + +Smt.Term + + +
Previous + Up + Next +
+

Module Smt.Term

+
+
module Term: sig .. end
+
type t
+
+The type of terms
+
+ +
type operator = + + + + + + + + + + + + + + + + + + + + + + + + +
+| +Plus(*+*)
+| +Minus(*-*)
+| +Mult(***)
+| +Div(*/*)
+| +Modulo(*mod*)
+ +
+The type of operators
+
+ +
val make_int : Num.num -> t
+make_int n creates an integer constant of value n.
+
+
val make_real : Num.num -> t
+make_real n creates an real constant of value n.
+
+
val make_app : Smt.Symbol.t -> t list -> t
+make_app f l creates the application of function symbol f to a list + of terms l.
+
+
val make_arith : operator -> t -> t -> t
+make_arith op t1 t2 creates the term t1 <op> t2.
+
+
val make_ite : Smt.Formula.t -> t -> t -> t
+make_ite f t1 t2 creates the term if f then t1 else t2.
+
+
val is_int : t -> bool
+is_int x is true if the term x has type int
+
+
val is_real : t -> bool
+is_real x is true if the term x has type real
+
+
val t_true : t
+t_true is the boolean term true
+
+
val t_false : t
+t_false is the boolean term false
+
+ \ No newline at end of file diff --git a/doc/Smt.Type.html b/doc/Smt.Type.html new file mode 100644 index 00000000..5236b200 --- /dev/null +++ b/doc/Smt.Type.html @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + +Smt.Type + + +
 Up + Next +
+

Module Smt.Type

+
+
module Type: sig .. end

Typing


+
+
type t = Hstring.t
+
+The type of types in Alt-Ergo Zero
+
+ +
+

Builtin types


+
val type_int : t
+The type of integers
+
+
val type_real : t
+The type of reals
+
+
val type_bool : t
+The type of booleans
+
+
val type_proc : t
+The type processes (identifiers)
+
+
+

Declaring new types


+
val declare : Hstring.t -> Hstring.t list -> unit
+
    +
  • declare n cstrs declares a new enumerated data-type with + name n and constructors cstrs.
    • +
  • declare n [] declares a new abstract type with name n.
    • +
+
+
+
val all_constructors : unit -> Hstring.t list
+all_constructors () returns a list of all the defined constructors.
+
+
val constructors : t -> Hstring.t list
+constructors ty returns the list of constructors of ty when type is + an enumerated data-type, otherwise returns [].
+
+ \ No newline at end of file diff --git a/doc/Smt.Variant.html b/doc/Smt.Variant.html new file mode 100644 index 00000000..2f1b3f33 --- /dev/null +++ b/doc/Smt.Variant.html @@ -0,0 +1,62 @@ + + + + + + + + + + + + + + + +Smt.Variant + + +
Previous + Up + Next +
+

Module Smt.Variant

+
+
module Variant: sig .. end

Variants

 +

+ + The types of symbols (when they are enumerated data types) can be refined + to substypes of their original type (i.e. a subset of their constructors).
+

+
val init : (Smt.Symbol.t * Smt.Type.t) list -> unit
+init l where l is a list of pairs (s, ty) initializes the + type (and associated constructors) of each s to its original type ty. +

+ + This function must be called with a list of all symbols before + attempting to refine the types.
+

+
val close : unit -> unit
+close () will compute the smallest type possible for each symbol. +

+ + This function must be called when all information has been added.
+

+
val assign_constr : Smt.Symbol.t -> Hstring.t -> unit
+assign_constr s cstr will add the constraint that the constructor + cstr must be in the type of s
+
+
val assign_var : Smt.Symbol.t -> Smt.Symbol.t -> unit
+assign_var x y will add the constraint that the type of y is a + subtype of x (use this function when x := y appear in your + program
+
+
val print : unit -> unit
+print () will output the computed refined types on std_err. This + function is here only for debugging purposes. Use it afer close ().
+
+
val get_variants : Smt.Symbol.t -> Hstring.HSet.t
+get_variants s returns a set of constructors, which is the refined + type of s.
+
+ \ No newline at end of file diff --git a/doc/Smt.html b/doc/Smt.html new file mode 100644 index 00000000..33bee2c1 --- /dev/null +++ b/doc/Smt.html @@ -0,0 +1,105 @@ + + + + + + + + + + + + + + + + + + + +Smt + + +
 Up + Next +
+

Module Smt

+
+
module Smt: sig .. end
The Alt-Ergo Zero SMT library +

+ + This SMT solver is derived from Alt-Ergo. It + uses an efficient SAT solver and supports the following quantifier free + theories:

    +
  • Equality and uninterpreted functions
    • +
  • Arithmetic (linear, non-linear, integer, reals)
    • +
  • Enumerated data-types
    • +
+ + This API makes heavy use of hash-consed strings. Please take a moment to + look at Hstring.
+
+
+

Error handling


+
type error = + + + + + + + + + + + + + + + + + + + +
+| +DuplicateTypeName of Hstring.t(*raised when a type is already declared*)
+| +DuplicateSymb of Hstring.t(*raised when a symbol is already declared*)
+| +UnknownType of Hstring.t(*raised when the given type is not declared*)
+| +UnknownSymb of Hstring.t(*raised when the given symbol is not declared*)
+ + +
exception Error of error
+
+

Typing


+
module Type: sig .. end
+Typing +
+
module Symbol: sig .. end
+Function symbols +
+
module Variant: sig .. end
+Variants +
+
+

Building terms


+
module Term: sig .. end

+

Building formulas


+
module Formula: sig .. end

+

The SMT solver


+
exception Unsat of int list
+
+The exception raised by Smt.Solver.check and Smt.Solver.assume when + the formula is unsatisfiable.
+
+
val set_cc : bool -> unit
+set_cc false deactivates congruence closure algorithm + (true by default).
+
+
module type Solver = sig .. end
module Make: 
functor (Dummy : sig
end) -> Solver
+Functor to create several instances of the solver +
+ \ No newline at end of file diff --git a/doc/index.html b/doc/index.html new file mode 100644 index 00000000..d1837d7b --- /dev/null +++ b/doc/index.html @@ -0,0 +1,34 @@ + + + + + + + + + + + + + + + +

+Index of types
+Index of exceptions
+Index of values
+Index of modules
+Index of module types
+

+ + + +
Smt
+The Alt-Ergo Zero SMT library +
+
Hstring
+Hash-consed strings +
+
+ + \ No newline at end of file diff --git a/doc/index_attributes.html b/doc/index_attributes.html new file mode 100644 index 00000000..fb4af8f6 --- /dev/null +++ b/doc/index_attributes.html @@ -0,0 +1,19 @@ + + + + + + + + + + + +Index of class attributes + + +

Index of class attributes

+ +

+ + \ No newline at end of file diff --git a/doc/index_class_types.html b/doc/index_class_types.html new file mode 100644 index 00000000..c58c17bb --- /dev/null +++ b/doc/index_class_types.html @@ -0,0 +1,19 @@ + + + + + + + + + + + +Index of class types + + +

Index of class types

+ +

+ + \ No newline at end of file diff --git a/doc/index_classes.html b/doc/index_classes.html new file mode 100644 index 00000000..30fe9b57 --- /dev/null +++ b/doc/index_classes.html @@ -0,0 +1,19 @@ + + + + + + + + + + + +Index of classes + + +

Index of classes

+ +

+ + \ No newline at end of file diff --git a/doc/index_exceptions.html b/doc/index_exceptions.html new file mode 100644 index 00000000..50e8c67c --- /dev/null +++ b/doc/index_exceptions.html @@ -0,0 +1,29 @@ + + + + + + + + + + + +Index of exceptions + + +

Index of exceptions

+ + + + + + + +

E
Error [Smt]

U
Unsat [Smt]
+The exception raised by Smt.Solver.check and Smt.Solver.assume when + the formula is unsatisfiable. +
+

+ + \ No newline at end of file diff --git a/doc/index_methods.html b/doc/index_methods.html new file mode 100644 index 00000000..1d9642bd --- /dev/null +++ b/doc/index_methods.html @@ -0,0 +1,19 @@ + + + + + + + + + + + +Index of class methods + + +

Index of class methods

+ +

+ + \ No newline at end of file diff --git a/doc/index_module_types.html b/doc/index_module_types.html new file mode 100644 index 00000000..41684149 --- /dev/null +++ b/doc/index_module_types.html @@ -0,0 +1,22 @@ + + + + + + + + + + + +Index of module types + + +

Index of module types

+ + + + +

S
Solver [Smt]

+ + \ No newline at end of file diff --git a/doc/index_modules.html b/doc/index_modules.html new file mode 100644 index 00000000..27b6af52 --- /dev/null +++ b/doc/index_modules.html @@ -0,0 +1,74 @@ + + + + + + + + + + + +Index of modules + + +

Index of modules

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

F
Formula [Smt]

H
H [Hstring]
+Hash-tables indexed by hash-consed strings +
+
HMap [Hstring]
+Maps indexed by hash-consed strings +
+
HSet [Hstring]
+Sets of hash-consed strings +
+
Hstring
+Hash-consed strings +
+

M
Make [Smt]
+Functor to create several instances of the solver +
+

S
Smt
+The Alt-Ergo Zero SMT library +
+
Symbol [Smt]
+Function symbols +
+

T
Term [Smt]
Type [Smt]
+Typing +
+

V
Variant [Smt]
+Variants +
+

+ + \ No newline at end of file diff --git a/doc/index_types.html b/doc/index_types.html new file mode 100644 index 00000000..162aa5b0 --- /dev/null +++ b/doc/index_types.html @@ -0,0 +1,72 @@ + + + + + + + + + + + +Index of types + + +

Index of types

+ + + + + + + + + + + + + + + + + + + + + + + + + + +

C
combinator [Smt.Formula]
+The type of operators +
+
comparator [Smt.Formula]
+The type of comparators: +
+

E
error [Smt]

O
operator [Smt.Term]
+The type of operators +
+

S
state [Smt.Solver]
+The type of the internal state of the solver (see Smt.Solver.save_state and + Smt.Solver.restore_state). +
+

T
t [Hstring]
+The type of Hash-consed string +
+
t [Smt.Formula]
+The type of ground formulas +
+
t [Smt.Term]
+The type of terms +
+
t [Smt.Symbol]
+The type of function symbols +
+
t [Smt.Type]
+The type of types in Alt-Ergo Zero +
+

+ + \ No newline at end of file diff --git a/doc/index_values.html b/doc/index_values.html new file mode 100644 index 00000000..4db77440 --- /dev/null +++ b/doc/index_values.html @@ -0,0 +1,325 @@ + + + + + + + + + + + +Index of values + + +

Index of values

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

A
all_constructors [Smt.Type]
+all_constructors () returns a list of all the defined constructors. +
+
assign_constr [Smt.Variant]
+assign_constr s cstr will add the constraint that the constructor + cstr must be in the type of s +
+
assign_var [Smt.Variant]
+assign_var x y will add the constraint that the type of y is a + subtype of x (use this function when x := y appear in your + program +
+
assume [Smt.Solver]
+assume ~profiling:b f id adds the formula f to the context of the + solver with idetifier id. +
+

C
check [Smt.Solver]
+check () runs Alt-Ergo Zero on its context. +
+
clear [Smt.Solver]
+clear () clears the context of the solver. +
+
close [Smt.Variant]
+close () will compute the smallest type possible for each symbol. +
+
compare [Hstring]
+compares x y returns 0 if x and y are equal, and is unspecified + otherwise but provides a total ordering on hash-consed strings. +
+
compare_list [Hstring]
+compare_list l1 l2 returns 0 if and only if l1 is equal to l2. +
+
constructors [Smt.Type]
+constructors ty returns the list of constructors of ty when type is + an enumerated data-type, otherwise returns []. +
+

D
declare [Smt.Symbol]
+declare s [arg_1; ... ; arg_n] out declares a new function + symbol with type (arg_1, ... , arg_n) -> out +
+
declare [Smt.Type]
+ declare n cstrs declares a new enumerated data-type with + name n and constructors cstrs., declare n [] declares a new abstract type with name n. +
+
declared [Smt.Symbol]
+declared x is true if x is already declared. +
+

E
empty [Hstring]
+the empty ("") hash-consed string. +
+
entails [Smt.Solver]
+entails ~id f returns true if the context of the solver entails + the formula f. +
+
equal [Hstring]
+equal x y returns true if x and y are the same hash-consed string + (constant time). +
+

F
f_false [Smt.Formula]
+The formula which represents false +
+
f_true [Smt.Formula]
+The formula which represents true +
+

G
get_calls [Smt.Solver]
+get_calls () returns the cumulated number of calls to Smt.Solver.check. +
+
get_time [Smt.Solver]
+get_time () returns the cumulated time spent in the solver in seconds. +
+
get_variants [Smt.Variant]
+get_variants s returns a set of constructors, which is the refined + type of s. +
+

H
has_abstract_type [Smt.Symbol]
+has_abstract_type x is true if the type of x is abstract. +
+
has_type_proc [Smt.Symbol]
+has_type_proc x is true if x has the type of a process + identifier. +
+
hash [Hstring]
+hash x returns the integer (hash) associated to x. +
+

I
init [Smt.Variant]
+init l where l is a list of pairs (s, ty) initializes the + type (and associated constructors) of each s to its original type ty. +
+
is_int [Smt.Term]
+is_int x is true if the term x has type int +
+
is_real [Smt.Term]
+is_real x is true if the term x has type real +
+

L
list_assoc [Hstring]
+list_assoc x l returns the element associated with x in the list of + pairs l. +
+
list_mem [Hstring]
+list_mem x l is true if and only if x is equal to an element of l. +
+
list_mem_assoc [Hstring]
+Same as Hstring.list_assoc, but simply returns true if a binding exists, and + false if no bindings exist for the given key. +
+
list_mem_couple [Hstring]
+list_mem_couple (x,y) l is true if and only if (x,y) is equal to an + element of l. +
+

M
make [Hstring]
+make s builds ans returns a hash-consed string from s. +
+
make [Smt.Formula]
+make cmb [f_1; ...; f_n] creates the formula + (f_1 <cmb> ... <cmb> f_n). +
+
make_app [Smt.Term]
+make_app f l creates the application of function symbol f to a list + of terms l. +
+
make_arith [Smt.Term]
+make_arith op t1 t2 creates the term t1 <op> t2. +
+
make_cnf [Smt.Formula]
+make_cnf f returns a conjunctive normal form of f under the form: a + list (which is a conjunction) of lists (which are disjunctions) of + literals. +
+
make_int [Smt.Term]
+make_int n creates an integer constant of value n. +
+
make_ite [Smt.Term]
+make_ite f t1 t2 creates the term if f then t1 else t2. +
+
make_lit [Smt.Formula]
+make_lit cmp [t1; t2] creates the literal (t1 <cmp> t2). +
+
make_real [Smt.Term]
+make_real n creates an real constant of value n. +
+

P
print [Hstring]
+Prints a list of hash-consed strings on a formatter. +
+
print [Smt.Formula]
+print fmt f prints the formula on the formatter fmt. +
+
print [Smt.Variant]
+print () will output the computed refined types on std_err. +
+

R
restore_state [Smt.Solver]
+restore_state s restores a previously saved state s. +
+

S
save_state [Smt.Solver]
+save_state () returns a copy of the current state of the solver. +
+
set_cc [Smt]
+set_cc false deactivates congruence closure algorithm + (true by default). +
+

T
t_false [Smt.Term]
+t_false is the boolean term false +
+
t_true [Smt.Term]
+t_true is the boolean term true +
+
type_bool [Smt.Type]
+The type of booleans +
+
type_int [Smt.Type]
+The type of integers +
+
type_of [Smt.Symbol]
+type_of x returns the type of x. +
+
type_proc [Smt.Type]
+The type processes (identifiers) +
+
type_real [Smt.Type]
+The type of reals +
+

V
view [Hstring]
+view hs returns the string corresponding to hs. +
+

+ + \ No newline at end of file diff --git a/doc/style.css b/doc/style.css new file mode 100644 index 00000000..9c84d311 --- /dev/null +++ b/doc/style.css @@ -0,0 +1,34 @@ +a:visited {color : #416DFF; text-decoration : none; } +a:link {color : #416DFF; text-decoration : none;} +a:hover {color : Red; text-decoration : none; background-color: #5FFF88} +a:active {color : Red; text-decoration : underline; } +.keyword { font-weight : bold ; color : Red } +.keywordsign { color : #C04600 } +.superscript { font-size : 4 } +.subscript { font-size : 4 } +.comment { color : Green } +.constructor { color : Blue } +.type { color : #5C6585 } +.string { color : Maroon } +.warning { color : Red ; font-weight : bold } +.info { margin-left : 3em; margin-right : 3em } +.param_info { margin-top: 4px; margin-left : 3em; margin-right : 3em } +.code { color : #465F91 ; } +h1 { font-size : 20pt ; text-align: center; } +h2 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ;padding: 2px; } +h3 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90DDFF ;padding: 2px; } +h4 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90EDFF ;padding: 2px; } +h5 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90FDFF ;padding: 2px; } +h6 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #C0FFFF ; padding: 2px; } +div.h7 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #E0FFFF ; padding: 2px; } +div.h8 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #F0FFFF ; padding: 2px; } +div.h9 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #FFFFFF ; padding: 2px; } +.typetable { border-style : hidden } +.indextable { border-style : hidden } +.paramstable { border-style : hidden ; padding: 5pt 5pt} +body { background-color : White } +tr { background-color : White } +td.typefieldcomment { background-color : #FFFFFF ; font-size: smaller ;} +pre { margin-bottom: 4px } +div.sig_block {margin-left: 2em} +*:target { background: yellow; } \ No newline at end of file diff --git a/doc/type_Hstring.H.html b/doc/type_Hstring.H.html new file mode 100644 index 00000000..e75ee543 --- /dev/null +++ b/doc/type_Hstring.H.html @@ -0,0 +1,29 @@ + + + + + + + + + + +Hstring.H + + +sig
+  type key = t
+  type 'a t
+  val create : int -> 'a t
+  val clear : 'a t -> unit
+  val copy : 'a t -> 'a t
+  val add : 'a t -> key -> 'a -> unit
+  val remove : 'a t -> key -> unit
+  val find : 'a t -> key -> 'a
+  val find_all : 'a t -> key -> 'a list
+  val replace : 'a t -> key -> 'a -> unit
+  val mem : 'a t -> key -> bool
+  val iter : (key -> 'a -> unit) -> 'a t -> unit
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val length : 'a t -> int
+end \ No newline at end of file diff --git a/doc/type_Hstring.HMap.html b/doc/type_Hstring.HMap.html new file mode 100644 index 00000000..11e8dbe1 --- /dev/null +++ b/doc/type_Hstring.HMap.html @@ -0,0 +1,42 @@ + + + + + + + + + + +Hstring.HMap + + +sig
+  type key = t
+  type +'a t
+  val empty : 'a t
+  val is_empty : 'a t -> bool
+  val mem : key -> 'a t -> bool
+  val add : key -> 'a -> 'a t -> 'a t
+  val singleton : key -> 'a -> 'a t
+  val remove : key -> 'a t -> 'a t
+  val merge :
+    (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+  val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+  val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+  val iter : (key -> 'a -> unit) -> 'a t -> unit
+  val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  val for_all : (key -> 'a -> bool) -> 'a t -> bool
+  val exists : (key -> 'a -> bool) -> 'a t -> bool
+  val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+  val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+  val cardinal : 'a t -> int
+  val bindings : 'a t -> (key * 'a) list
+  val min_binding : 'a t -> key * 'a
+  val max_binding : 'a t -> key * 'a
+  val choose : 'a t -> key * 'a
+  val split : key -> 'a t -> 'a t * 'a option * 'a t
+  val find : key -> 'a t -> 'a
+  val map : ('a -> 'b) -> 'a t -> 'b t
+  val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+end \ No newline at end of file diff --git a/doc/type_Hstring.HSet.html b/doc/type_Hstring.HSet.html new file mode 100644 index 00000000..5b36f864 --- /dev/null +++ b/doc/type_Hstring.HSet.html @@ -0,0 +1,41 @@ + + + + + + + + + + +Hstring.HSet + + +sig
+  type elt = t
+  type t
+  val empty : t
+  val is_empty : t -> bool
+  val mem : elt -> t -> bool
+  val add : elt -> t -> t
+  val singleton : elt -> t
+  val remove : elt -> t -> t
+  val union : t -> t -> t
+  val inter : t -> t -> t
+  val diff : t -> t -> t
+  val compare : t -> t -> int
+  val equal : t -> t -> bool
+  val subset : t -> t -> bool
+  val iter : (elt -> unit) -> t -> unit
+  val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+  val for_all : (elt -> bool) -> t -> bool
+  val exists : (elt -> bool) -> t -> bool
+  val filter : (elt -> bool) -> t -> t
+  val partition : (elt -> bool) -> t -> t * t
+  val cardinal : t -> int
+  val elements : t -> elt list
+  val min_elt : t -> elt
+  val max_elt : t -> elt
+  val choose : t -> elt
+  val split : elt -> t -> t * bool * t
+end \ No newline at end of file diff --git a/doc/type_Hstring.html b/doc/type_Hstring.html new file mode 100644 index 00000000..ec254215 --- /dev/null +++ b/doc/type_Hstring.html @@ -0,0 +1,105 @@ + + + + + + + + + + +Hstring + + +sig
+  type t = string Hashcons.hash_consed
+  val make : string -> Hstring.t
+  val view : Hstring.t -> string
+  val equal : Hstring.t -> Hstring.t -> bool
+  val compare : Hstring.t -> Hstring.t -> int
+  val hash : Hstring.t -> int
+  val empty : Hstring.t
+  val list_assoc : Hstring.t -> (Hstring.t * 'a) list -> 'a
+  val list_mem_assoc : Hstring.t -> (Hstring.t * 'a) list -> bool
+  val list_mem : Hstring.t -> Hstring.t list -> bool
+  val list_mem_couple :
+    Hstring.t * Hstring.t -> (Hstring.t * Hstring.t) list -> bool
+  val compare_list : Hstring.t list -> Hstring.t list -> int
+  val print : Format.formatter -> Hstring.t -> unit
+  module H :
+    sig
+      type key = t
+      type 'a t
+      val create : int -> 'a t
+      val clear : 'a t -> unit
+      val copy : 'a t -> 'a t
+      val add : 'a t -> key -> 'a -> unit
+      val remove : 'a t -> key -> unit
+      val find : 'a t -> key -> 'a
+      val find_all : 'a t -> key -> 'a list
+      val replace : 'a t -> key -> 'a -> unit
+      val mem : 'a t -> key -> bool
+      val iter : (key -> 'a -> unit) -> 'a t -> unit
+      val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+      val length : 'a t -> int
+    end
+  module HSet :
+    sig
+      type elt = t
+      type t
+      val empty : t
+      val is_empty : t -> bool
+      val mem : elt -> t -> bool
+      val add : elt -> t -> t
+      val singleton : elt -> t
+      val remove : elt -> t -> t
+      val union : t -> t -> t
+      val inter : t -> t -> t
+      val diff : t -> t -> t
+      val compare : t -> t -> int
+      val equal : t -> t -> bool
+      val subset : t -> t -> bool
+      val iter : (elt -> unit) -> t -> unit
+      val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+      val for_all : (elt -> bool) -> t -> bool
+      val exists : (elt -> bool) -> t -> bool
+      val filter : (elt -> bool) -> t -> t
+      val partition : (elt -> bool) -> t -> t * t
+      val cardinal : t -> int
+      val elements : t -> elt list
+      val min_elt : t -> elt
+      val max_elt : t -> elt
+      val choose : t -> elt
+      val split : elt -> t -> t * bool * t
+    end
+  module HMap :
+    sig
+      type key = t
+      type +'a t
+      val empty : 'a t
+      val is_empty : 'a t -> bool
+      val mem : key -> 'a t -> bool
+      val add : key -> 'a -> 'a t -> 'a t
+      val singleton : key -> 'a -> 'a t
+      val remove : key -> 'a t -> 'a t
+      val merge :
+        (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
+      val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+      val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+      val iter : (key -> 'a -> unit) -> 'a t -> unit
+      val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+      val for_all : (key -> 'a -> bool) -> 'a t -> bool
+      val exists : (key -> 'a -> bool) -> 'a t -> bool
+      val filter : (key -> 'a -> bool) -> 'a t -> 'a t
+      val partition : (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
+      val cardinal : 'a t -> int
+      val bindings : 'a t -> (key * 'a) list
+      val min_binding : 'a t -> key * 'a
+      val max_binding : 'a t -> key * 'a
+      val choose : 'a t -> key * 'a
+      val split : key -> 'a t -> 'a t * 'a option * 'a t
+      val find : key -> 'a t -> 'a
+      val map : ('a -> 'b) -> 'a t -> 'b t
+      val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+    end
+end \ No newline at end of file diff --git a/doc/type_Smt.Formula.html b/doc/type_Smt.Formula.html new file mode 100644 index 00000000..8a6e6004 --- /dev/null +++ b/doc/type_Smt.Formula.html @@ -0,0 +1,26 @@ + + + + + + + + + + +Smt.Formula + + +sig
+  type comparator = Eq | Neq | Le | Lt
+  type combinator = And | Or | Imp | Not
+  type t =
+      Lit of Literal.LT.t
+    | Comb of Smt.Formula.combinator * Smt.Formula.t list
+  val f_true : Smt.Formula.t
+  val f_false : Smt.Formula.t
+  val make_lit : Smt.Formula.comparator -> Smt.Term.t list -> Smt.Formula.t
+  val make : Smt.Formula.combinator -> Smt.Formula.t list -> Smt.Formula.t
+  val make_cnf : Smt.Formula.t -> Literal.LT.t list list
+  val print : Format.formatter -> Smt.Formula.t -> unit
+end \ No newline at end of file diff --git a/doc/type_Smt.Make.html b/doc/type_Smt.Make.html new file mode 100644 index 00000000..0d7c496d --- /dev/null +++ b/doc/type_Smt.Make.html @@ -0,0 +1,14 @@ + + + + + + + + + + +Smt.Make + + +functor (Dummy : sig  end) -> Solver \ No newline at end of file diff --git a/doc/type_Smt.Solver.html b/doc/type_Smt.Solver.html new file mode 100644 index 00000000..26a75e1a --- /dev/null +++ b/doc/type_Smt.Solver.html @@ -0,0 +1,24 @@ + + + + + + + + + + +Smt.Solver + + +sig
+  type state
+  val get_time : unit -> float
+  val get_calls : unit -> int
+  val clear : unit -> unit
+  val assume : ?profiling:bool -> id:int -> Smt.Formula.t -> unit
+  val check : ?profiling:bool -> unit -> unit
+  val save_state : unit -> Smt.Solver.state
+  val restore_state : Smt.Solver.state -> unit
+  val entails : ?profiling:bool -> id:int -> Smt.Formula.t -> bool
+end \ No newline at end of file diff --git a/doc/type_Smt.Symbol.html b/doc/type_Smt.Symbol.html new file mode 100644 index 00000000..dcd06375 --- /dev/null +++ b/doc/type_Smt.Symbol.html @@ -0,0 +1,21 @@ + + + + + + + + + + +Smt.Symbol + + +sig
+  type t = Hstring.t
+  val declare : Hstring.t -> Smt.Type.t list -> Smt.Type.t -> unit
+  val type_of : Smt.Symbol.t -> Smt.Type.t list * Smt.Type.t
+  val has_abstract_type : Smt.Symbol.t -> bool
+  val has_type_proc : Smt.Symbol.t -> bool
+  val declared : Smt.Symbol.t -> bool
+end \ No newline at end of file diff --git a/doc/type_Smt.Term.html b/doc/type_Smt.Term.html new file mode 100644 index 00000000..e6a41971 --- /dev/null +++ b/doc/type_Smt.Term.html @@ -0,0 +1,27 @@ + + + + + + + + + + +Smt.Term + + +sig
+  type t
+  type operator = Plus | Minus | Mult | Div | Modulo
+  val make_int : Num.num -> Smt.Term.t
+  val make_real : Num.num -> Smt.Term.t
+  val make_app : Smt.Symbol.t -> Smt.Term.t list -> Smt.Term.t
+  val make_arith :
+    Smt.Term.operator -> Smt.Term.t -> Smt.Term.t -> Smt.Term.t
+  val make_ite : Smt.Formula.t -> Smt.Term.t -> Smt.Term.t -> Smt.Term.t
+  val is_int : Smt.Term.t -> bool
+  val is_real : Smt.Term.t -> bool
+  val t_true : Smt.Term.t
+  val t_false : Smt.Term.t
+end \ No newline at end of file diff --git a/doc/type_Smt.Type.html b/doc/type_Smt.Type.html new file mode 100644 index 00000000..d14a5a63 --- /dev/null +++ b/doc/type_Smt.Type.html @@ -0,0 +1,23 @@ + + + + + + + + + + +Smt.Type + + +sig
+  type t = Hstring.t
+  val type_int : Smt.Type.t
+  val type_real : Smt.Type.t
+  val type_bool : Smt.Type.t
+  val type_proc : Smt.Type.t
+  val declare : Hstring.t -> Hstring.t list -> unit
+  val all_constructors : unit -> Hstring.t list
+  val constructors : Smt.Type.t -> Hstring.t list
+end \ No newline at end of file diff --git a/doc/type_Smt.Variant.html b/doc/type_Smt.Variant.html new file mode 100644 index 00000000..5736af72 --- /dev/null +++ b/doc/type_Smt.Variant.html @@ -0,0 +1,21 @@ + + + + + + + + + + +Smt.Variant + + +sig
+  val init : (Smt.Symbol.t * Smt.Type.t) list -> unit
+  val close : unit -> unit
+  val assign_constr : Smt.Symbol.t -> Hstring.t -> unit
+  val assign_var : Smt.Symbol.t -> Smt.Symbol.t -> unit
+  val print : unit -> unit
+  val get_variants : Smt.Symbol.t -> Hstring.HSet.t
+end \ No newline at end of file diff --git a/doc/type_Smt.html b/doc/type_Smt.html new file mode 100644 index 00000000..3b6f4362 --- /dev/null +++ b/doc/type_Smt.html @@ -0,0 +1,96 @@ + + + + + + + + + + +Smt + + +sig
+  type error =
+      DuplicateTypeName of Hstring.t
+    | DuplicateSymb of Hstring.t
+    | UnknownType of Hstring.t
+    | UnknownSymb of Hstring.t
+  exception Error of Smt.error
+  module Type :
+    sig
+      type t = Hstring.t
+      val type_int : Smt.Type.t
+      val type_real : Smt.Type.t
+      val type_bool : Smt.Type.t
+      val type_proc : Smt.Type.t
+      val declare : Hstring.t -> Hstring.t list -> unit
+      val all_constructors : unit -> Hstring.t list
+      val constructors : Smt.Type.t -> Hstring.t list
+    end
+  module Symbol :
+    sig
+      type t = Hstring.t
+      val declare : Hstring.t -> Smt.Type.t list -> Smt.Type.t -> unit
+      val type_of : Smt.Symbol.t -> Smt.Type.t list * Smt.Type.t
+      val has_abstract_type : Smt.Symbol.t -> bool
+      val has_type_proc : Smt.Symbol.t -> bool
+      val declared : Smt.Symbol.t -> bool
+    end
+  module Variant :
+    sig
+      val init : (Smt.Symbol.t * Smt.Type.t) list -> unit
+      val close : unit -> unit
+      val assign_constr : Smt.Symbol.t -> Hstring.t -> unit
+      val assign_var : Smt.Symbol.t -> Smt.Symbol.t -> unit
+      val print : unit -> unit
+      val get_variants : Smt.Symbol.t -> Hstring.HSet.t
+    end
+  module rec Term :
+    sig
+      type t
+      type operator = Plus | Minus | Mult | Div | Modulo
+      val make_int : Num.num -> Smt.Term.t
+      val make_real : Num.num -> Smt.Term.t
+      val make_app : Smt.Symbol.t -> Smt.Term.t list -> Smt.Term.t
+      val make_arith :
+        Smt.Term.operator -> Smt.Term.t -> Smt.Term.t -> Smt.Term.t
+      val make_ite : Smt.Formula.t -> Smt.Term.t -> Smt.Term.t -> Smt.Term.t
+      val is_int : Smt.Term.t -> bool
+      val is_real : Smt.Term.t -> bool
+      val t_true : Smt.Term.t
+      val t_false : Smt.Term.t
+    end
+  and Formula :
+    sig
+      type comparator = Eq | Neq | Le | Lt
+      type combinator = And | Or | Imp | Not
+      type t =
+          Lit of Literal.LT.t
+        | Comb of Smt.Formula.combinator * Smt.Formula.t list
+      val f_true : Smt.Formula.t
+      val f_false : Smt.Formula.t
+      val make_lit :
+        Smt.Formula.comparator -> Smt.Term.t list -> Smt.Formula.t
+      val make :
+        Smt.Formula.combinator -> Smt.Formula.t list -> Smt.Formula.t
+      val make_cnf : Smt.Formula.t -> Literal.LT.t list list
+      val print : Format.formatter -> Smt.Formula.t -> unit
+    end
+  exception Unsat of int list
+  val set_cc : bool -> unit
+  module type Solver =
+    sig
+      type state
+      val get_time : unit -> float
+      val get_calls : unit -> int
+      val clear : unit -> unit
+      val assume : ?profiling:bool -> id:int -> Smt.Formula.t -> unit
+      val check : ?profiling:bool -> unit -> unit
+      val save_state : unit -> Smt.Solver.state
+      val restore_state : Smt.Solver.state -> unit
+      val entails : ?profiling:bool -> id:int -> Smt.Formula.t -> bool
+    end
+  module Make : functor (Dummy : sig  end) -> Solver
+end \ No newline at end of file diff --git a/smt/arith.ml b/smt/arith.ml new file mode 100644 index 00000000..fd6cf229 --- /dev/null +++ b/smt/arith.ml @@ -0,0 +1,435 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Alain Mebsout *) +(* Francois Bobot, Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format +open Sig +open Num +module A = Literal +module Sy = Symbols +module T = Term + +let ale = Hstring.make "<=" +let alt = Hstring.make "<" +let is_le n = Hstring.compare n ale = 0 +let is_lt n = Hstring.compare n alt = 0 +let is_mult h = Sy.equal (Sy.Op Sy.Mult) h +let mod_symb = Sy.name (Hstring.make "@mod") + +module Type (X:Sig.X) : Polynome.T with type r = X.r = struct + + let mult _ _ = assert false + + include Polynome.Make(struct include X let mult = mult end) + +end + +module Make + (X : Sig.X) + (P : Polynome.T with type r = X.r) + (C : Sig.C with type t = P.t and type r = X.r) = struct + + type t = P.t + + type r = P.r + + let name = "arith" + + let is_mine_a a = + match A.LT.view a with + | A.Builtin (_,p,_) -> is_le p || is_lt p + | _ -> false + + let is_mine_symb = function + | Sy.Int _ | Sy.Real _ + | Sy.Op (Sy.Plus | Sy.Minus | Sy.Mult | Sy.Div | Sy.Modulo) -> true + | _ -> false + + let is_mine_type p = + let ty = P.type_info p in + ty = Ty.Tint || ty = Ty.Treal + + let unsolvable _ = false + + let empty_polynome ty = P.create [] (Int 0) ty + + let is_mine p = match P.is_monomial p with + | Some (a,x,b) when a =/ (Int 1) && b =/ (Int 0) -> x + | _ -> C.embed p + + let embed r = match C.extract r with + | Some p -> p + | _ -> P.create [Int 1, r] (Int 0) (X.type_info r) + + let check_int exn p = + if P.type_info p = Ty.Tint then + let _, c = P.to_list p in + let ppmc = P.ppmc_denominators p in + if not (is_integer_num (ppmc */ c)) then raise exn + + let fresh_string = + let cpt = ref 0 in + fun () -> + incr cpt; + "!k" ^ (string_of_int !cpt) + + let fresh_name () = + T.make (Sy.name (Hstring.make (fresh_string()))) [] Ty.Tint + + (* t1 % t2 = md <-> + c1. 0 <= md ; + c2. md < t2 ; + c3. exists k. t1 = t2 * k + t ; + c4. t2 <> 0 (already checked) *) + let mk_modulo md t1 t2 ctx = + let zero = T.int "0" in + let c1 = A.LT.make (A.Builtin(true, ale, [zero; md])) in + let c2 = A.LT.make (A.Builtin(true, alt, [md; t2])) in + let k = fresh_name () in + let t3 = T.make (Sy.Op Sy.Mult) [t2;k] Ty.Tint in + let t3 = T.make (Sy.Op Sy.Plus) [t3;md] Ty.Tint in + let c3 = A.LT.make (A.Eq (t1, t3)) in + c3 :: c2 :: c1 :: ctx + + let mk_euc_division p p2 t1 t2 ctx = + match P.to_list p2 with + | [], coef_p2 -> + let md = T.make (Sy.Op Sy.Modulo) [t1;t2] Ty.Tint in + let r, ctx' = X.make md in + let rp = P.mult (P.create [] ((Int 1) //coef_p2) Ty.Tint) (embed r) in + P.sub p rp, ctx' @ ctx + | _ -> assert false + + let rec mke coef p t ctx = + let {T.f = sb ; xs = xs; ty = ty} = T.view t in + match sb, xs with + | (Sy.Int n | Sy.Real n), _ -> + let c = coef */ (num_of_string (Hstring.view n)) in + P.add (P.create [] c ty) p, ctx + + | Sy.Op Sy.Mult, [t1;t2] -> + let p1, ctx = mke coef (empty_polynome ty) t1 ctx in + let p2, ctx = mke (Int 1) (empty_polynome ty) t2 ctx in + P.add p (P.mult p1 p2), ctx + + | Sy.Op Sy.Div, [t1;t2] -> + let p1, ctx = mke coef (empty_polynome ty) t1 ctx in + let p2, ctx = mke (Int 1) (empty_polynome ty) t2 ctx in + let p3, ctx = + try + let p, approx = P.div p1 p2 in + if approx then mk_euc_division p p2 t1 t2 ctx + else p, ctx + with Division_by_zero | Polynome.Maybe_zero -> + P.create [coef, X.term_embed t] (Int 0) ty, ctx + in + P.add p p3, ctx + + | Sy.Op Sy.Plus , [t1;t2] -> + let p2, ctx = mke coef p t2 ctx in + mke coef p2 t1 ctx + + | Sy.Op Sy.Minus , [t1;t2] -> + let p2, ctx = mke (minus_num coef) p t2 ctx in + mke coef p2 t1 ctx + + | Sy.Op Sy.Modulo , [t1;t2] -> + let p1, ctx = mke coef (empty_polynome ty) t1 ctx in + let p2, ctx = mke (Int 1) (empty_polynome ty) t2 ctx in + let p3, ctx = + try P.modulo p1 p2, ctx + with e -> + let t = T.make mod_symb [t1; t2] Ty.Tint in + let ctx = match e with + | Division_by_zero | Polynome.Maybe_zero -> ctx + | Polynome.Not_a_num -> mk_modulo t t1 t2 ctx + | _ -> assert false + in + P.create [coef, X.term_embed t] (Int 0) ty, ctx + in + P.add p p3, ctx + + | _ -> + let a, ctx' = X.make t in + let ctx = ctx' @ ctx in + match C.extract a with + | Some p' -> P.add p (P.mult (P.create [] coef ty) p'), ctx + | _ -> P.add p (P.create [coef, a] (Int 0) ty), ctx + + let arith_to_ac p = p +(* + match P.to_list p with + | [] , c -> p + | [Int 1, x] , Int 0 -> p + | l , c -> + let ty = P.type_info p in + let l = + List.fold_left + (fun acc (coef,x) -> + if coef =/ Int 0 then acc + else if coef =/ Int 1 || coef =/ Int (-1) then (coef,x)::acc + else match X.ac_extract x with + | Some ac when is_mult ac.h -> + let unit_coef, abs_coef = + if coef > Int 0 then Int 1, coef + else Int (-1), minus_num coef + in + let p_cst = is_mine (P.create [] abs_coef ty) in + let ac = {ac with l = Ac.add ac.h (p_cst, 1) ac.l} in + (unit_coef, X.ac_embed ac)::acc + | _ -> (coef,x)::acc + )[] l + in + P.create l c ty +*) + let make t = + let {T.ty = ty} = T.view t in + let p, ctx = mke (Int 1) (empty_polynome ty) t [] in + is_mine (arith_to_ac p), ctx + + let rec expand p n acc = + assert (n >=0); + if n = 0 then acc else expand p (n-1) (p::acc) + + let rec number_of_vars l = + List.fold_left (fun acc (r, n) -> acc + n * nb_vars_in_alien r) 0 l + + and nb_vars_in_alien r = + match C.extract r with + | Some p -> + let l, _ = P.to_list p in + List.fold_left (fun acc (a, x) -> max acc (nb_vars_in_alien x)) 0 l + | None -> 1 + + let max_list_ = function + | [] -> 0 + | [ _, x ] -> nb_vars_in_alien x + | (_, x) :: l -> + let acc = nb_vars_in_alien x in + List.fold_left (fun acc (_, x) -> max acc (nb_vars_in_alien x)) acc l + + let type_info p = P.type_info p + + let is_int r = X.type_info r = Ty.Tint + + module XS = Set.Make(struct type t = X.r let compare = X.compare end) + + let xs_of_list = + List.fold_left (fun s x -> XS.add x s) XS.empty + + let rec leaves p = + let s = + List.fold_left + (fun s (_, a) -> XS.union (xs_of_list (X.leaves a)) s) + XS.empty (fst (P.to_list p)) + in + XS.elements s + + let subst x t p = + let p = P.subst x (embed t) p in + let ty = P.type_info p in + let l, c = P.to_list p in + let p = + List.fold_left + (fun p (ai, xi) -> + let xi' = X.subst x t xi in + let p' = match C.extract xi' with + | Some p' -> P.mult (P.create [] ai ty) p' + | _ -> P.create [ai, xi'] (Int 0) ty + in + P.add p p') + (P.create [] c ty) l + in + check_int (Exception.Unsolvable) p; + is_mine p + + + let compare = P.compare + + let hash = P.hash + + (* symmetric modulo p 131 *) + let mod_sym a b = + let m = mod_num a b in + let m = + if m =/ minus_num b then m +/ b else assert false + else + if m <=/ b then m else assert false + + in + if m + let a = f a in if a =/ Int 0 then acc else (a, x) :: acc) + [ax] l + + let apply_subst sb v = + is_mine (List.fold_left (fun v (x, p) -> embed (subst x p v)) v sb) + + (* substituer toutes variables plus grandes que x *) + let subst_bigger x l = + List.fold_left + (fun (l, sb) (b, y) -> + if X.compare y x > 0 then + let k = X.term_embed (fresh_name ()) in + (b, k) :: l, (y, embed k)::sb + else (b, y) :: l, sb) + ([], []) l + + let is_mine_p = List.map (fun (x,p) -> x, is_mine p) + + let extract_min = function + | [] -> assert false + | [c] -> c, [] + | (a, x) :: s -> + List.fold_left + (fun ((a, x), l) (b, y) -> + if abs_num a <=/ abs_num b then + (a, x), ((b, y) :: l) + else (b, y), ((a, x):: l)) ((a, x),[]) s + + + (* Decision Procedures. Page 131 *) + let rec omega l b = + + (* 1. choix d'une variable donc le |coef| est minimal *) + let (a, x), l = extract_min l in + + (* 2. substituer les aliens plus grand que x pour + assurer l'invariant sur l'ordre AC *) + let l, sbs = subst_bigger x l in + let p = P.create l b Ty.Tint in + match a with + | Int 0 -> assert false + | Int 1 -> + (* 3.1. si a = 1 alors on a une substitution entiere pour x *) + let p = mult_const p (Int (-1)) in + (x, is_mine p) :: (is_mine_p sbs) + + | Int (-1) -> + (* 3.2. si a = -1 alors on a une subst entiere pour x*) + (x,is_mine p) :: (is_mine_p sbs) + | _ -> + (* 4. sinon, (|a| <> 1) et a <> 0 *) + (* 4.1. on rend le coef a positif s'il ne l'est pas deja *) + let a, l, b = + if compare_num a (Int 0) < 0 then + (minus_num a, + List.map (fun (a,x) -> minus_num a,x) l, (minus_num b)) + else (a, l, b) + in + (* 4.2. on reduit le systeme *) + omega_sigma sbs a x l b + + and omega_sigma sbs a x l b = + + (* 1. on definie m qui vaut a + 1 *) + let m = a +/ Int 1 in + + (* 2. on introduit une variable fraiche *) + let sigma = X.term_embed (fresh_name ()) in + + (* 3. l'application de la formule (5.63) nous donne la valeur du pivot x*) + let mm_sigma = (minus_num m, sigma) in + let l_mod = map_monomes (fun a -> mod_sym a m) l mm_sigma in + + (* 3.1. Attention au signe de b : + on le passe a droite avant de faire mod_sym, d'ou minus_num *) + let b_mod = minus_num (mod_sym (minus_num b) m) in + let p = P.create l_mod b_mod Ty.Tint in + + let sbs = (x, p) :: sbs in + + (* 4. on substitue x par sa valeur dans l'equation de depart. + Voir la formule (5.64) *) + let p' = P.add (P.mult_const a p) (P.create l b Ty.Tint) in + + (* 5. on resoud sur l'equation simplifiee *) + let sbs2 = solve_int p' in + + (* 6. on normalise sbs par sbs2 *) + let sbs = List.map (fun (x, v) -> x, apply_subst sbs2 v) sbs in + + (* 7. on supprime les liaisons inutiles de sbs2 et on merge avec sbs *) + let sbs2 = List.filter (fun (y, _) -> y <> sigma) sbs2 in + List.rev_append sbs sbs2 + + and solve_int p = + if P.is_empty p then raise Not_found; + let pgcd = P.pgcd_numerators p in + let ppmc = P.ppmc_denominators p in + let p = mult_const p (ppmc // pgcd) in + let l, b = P.to_list p in + if not (is_integer_num b) then raise Exception.Unsolvable; + omega l b + + let is_null p = + if snd (P.to_list p) <>/ (Int 0) then raise Exception.Unsolvable; + [] + + let solve_int p = + try solve_int p with Not_found -> is_null p + + let solve_real p = + try + let a, x = P.choose p in + let p = + P.mult + (P.create [] ((Int (-1)) // a) (P.type_info p)) + (P.remove x p) + in + [x, is_mine p] + with Not_found -> is_null p + + let safe_distribution p = + let l, c = P.to_list p in + let ty = P.type_info p in + List.fold_left + (fun p (coef, x) -> P.add p (P.create [coef,x] (Int 0) ty)) + (P.create [] c ty) l + + let solve_aux r1 r2 = + let p1 = embed r1 in + let p2 = embed r2 in + let ty = P.type_info p2 in + let p = P.add p1 (P.mult (P.create [] (Int (-1)) ty) p2) in + let pp = safe_distribution p in + if ty = Ty.Treal then solve_real pp else solve_int pp + + let solve r1 r2 = + let sbs = solve_aux r1 r2 in + List.fast_sort (fun (a,_) (x,y) -> X.compare x a) sbs + + let print = P.print + + let fully_interpreted sb = + match sb with + | Sy.Op (Sy.Plus | Sy.Minus) -> true + | _ -> false + + let term_extract _ = None + + module Rel = Fm.Make (X) + (struct + include P + let poly_of = embed + let alien_of = is_mine + end) + +end diff --git a/smt/arith.mli b/smt/arith.mli new file mode 100644 index 00000000..4c47b555 --- /dev/null +++ b/smt/arith.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Alain Mebsout *) +(* Francois Bobot, Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module Type (X : Sig.X ): Polynome.T with type r = X.r + +module Make + (X : Sig.X) + (P : Polynome.T with type r = X.r) + (C : Sig.C with type t = P.t and type r = X.r) : Sig.THEORY + with type r = X.r and type t = P.t diff --git a/smt/cc.ml b/smt/cc.ml new file mode 100644 index 00000000..68b5287a --- /dev/null +++ b/smt/cc.ml @@ -0,0 +1,524 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Evelyne Contejean *) +(* Francois Bobot, Mohamed Iguernelala, Alain Mebsout *) +(* CNRS, Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format +open Sig +open Exception + +let max_split = Num.Int 1000000 + +let cc_active = ref true + +module type S = sig + type t + + module TimerCC : Timer.S + + val empty : unit -> t + val assume : cs:bool -> + Literal.LT.t -> Explanation.t -> t -> t * Term.Set.t * int + val query : Literal.LT.t -> t -> answer + val class_of : t -> Term.t -> Term.t list +end + +module Make (X : Sig.X) = struct + + module TimerCC = Timer.Make(struct end) + + module Ex = Explanation + module SetA = Use.SA + module Use = Use.Make(X) + module Uf = Uf.Make(X) + module T = Term + module A = Literal + module LR = A.Make(struct type t = X.r include X end) + module SetT = Term.Set + module S = Symbols + + module SetX = Set.Make(struct type t = X.r let compare = X.compare end) + + (* module Uf = Pptarjan.Uf *) + + type env = { + use : Use.t; + uf : Uf.t ; + relation : X.Rel.t + } + + type choice_sign = + | CPos of int (* The explication of this choice *) + | CNeg (* The choice has been already negated *) + + type t = { + gamma : env; + gamma_finite : env ; + choices : (X.r A.view * Num.num * choice_sign * Ex.t) list; + (** the choice, the size, choice_sign, the explication set, + the explication for this choice. *) + } + + module Print = struct + + let begin_case_split () = () + + let end_case_split () = () + + let cc r1 r2 = () + + let make_cst t ctx = () + + let add_to_use t = () + + let lrepr fmt = List.iter (fprintf fmt "%a " X.print) + + let leaves t lvs = () + + let contra_congruence a ex = () + + let split_size sz = () + + let split_backtrack neg_c ex_c = () + + let split_assume c ex_c = () + + let split_backjump c dep = () + + let assume_literal sa = () + + let congruent a ex = () + + let query a = () + + end + + let bottom = Hstring.make "@bottom" + let one, _ = X.make (Term.make (S.name bottom) [] Ty.Tint) + + let concat_leaves uf l = + let rec concat_rec acc t = + match X.leaves (fst (Uf.find uf t)) , acc with + [] , _ -> one::acc + | res, [] -> res + | res , _ -> List.rev_append res acc + in + match List.fold_left concat_rec [] l with + [] -> [one] + | res -> res + + let are_equal env ex t1 t2 = + if T.equal t1 t2 then ex + else match Uf.are_equal env.uf t1 t2 with + | Yes dep -> Ex.union ex dep + | No -> raise Exit + + let equal_only_by_congruence env ex t1 t2 acc = + if T.equal t1 t2 then acc + else + let {T.f=f1; xs=xs1; ty=ty1} = T.view t1 in + if X.fully_interpreted f1 then acc + else + let {T.f=f2; xs=xs2; ty=ty2} = T.view t2 in + if Symbols.equal f1 f2 && Ty.equal ty1 ty2 then + try + let ex = List.fold_left2 (are_equal env) ex xs1 xs2 in + let a = A.LT.make (A.Eq(t1, t2)) in + Print.congruent a ex; + (LTerm a, ex) :: acc + with Exit -> acc + else acc + + let congruents env t1 s acc ex = + SetT.fold (equal_only_by_congruence env ex t1) s acc + + let fold_find_with_explanation find ex l = + List.fold_left + (fun (lr, ex) t -> let r, ex_r = find t in r::lr, Ex.union ex_r ex) + ([], ex) l + + let view find va ex_a = + match va with + | A.Eq (t1, t2) -> + let r1, ex1 = find t1 in + let r2, ex2 = find t2 in + let ex = Ex.union (Ex.union ex1 ex2) ex_a in + A.Eq(r1, r2), ex + | A.Distinct (b, lt) -> + let lr, ex = fold_find_with_explanation find ex_a lt in + A.Distinct (b, lr), ex + | A.Builtin(b, s, l) -> + let lr, ex = fold_find_with_explanation find ex_a l in + A.Builtin(b, s, List.rev lr), ex + + let term_canonical_view env a ex_a = + view (Uf.find env.uf) (A.LT.view a) ex_a + + let canonical_view env a ex_a = view (Uf.find_r env.uf) a ex_a + + let new_facts_by_contra_congruence env r bol ex = + match X.term_extract r with + | None -> [] + | Some t1 -> + match T.view t1 with + | {T.f=f1 ; xs=[x]} -> + List.fold_left + (fun acc t2 -> + match T.view t2 with + | {T.f=f2 ; xs=[y]} when S.equal f1 f2 -> + let a = A.LT.make (A.Distinct (false, [x; y])) in + let dist = LTerm a in + begin match Uf.are_distinct env.uf t1 t2 with + | Yes ex' -> + let ex_r = Ex.union ex ex' in + Print.contra_congruence a ex_r; + (dist, ex_r) :: acc + | No -> assert false + end + | _ -> acc + ) [] (Uf.class_of env.uf bol) + | _ -> [] + + let contra_congruence = + let vrai,_ = X.make T.vrai in + let faux, _ = X.make T.faux in + fun env r ex -> + if X.equal (fst (Uf.find_r env.uf r)) vrai then + new_facts_by_contra_congruence env r T.faux ex + else if X.equal (fst (Uf.find_r env.uf r)) faux then + new_facts_by_contra_congruence env r T.vrai ex + else [] + + let clean_use = + List.fold_left + (fun env (a, ex) -> + match a with + | LSem _ -> assert false + | LTerm t -> + begin + match A.LT.view t with + | A.Distinct (_, lt) + | A.Builtin (_, _, lt) -> + let lvs = concat_leaves env.uf lt in + List.fold_left + (fun env rx -> + let st, sa = Use.find rx env.use in + let sa = SetA.remove (t, ex) sa in + { env with use = Use.add rx (st,sa) env.use } + ) env lvs + | _ -> assert false + end) + + let rec congruence_closure env r1 r2 ex = + Print.cc r1 r2; + let uf, res = Uf.union env.uf r1 r2 ex in + List.fold_left + (fun (env, l) (p, touched, v) -> + (* we look for use(p) *) + let p_t, p_a = Use.find p env.use in + + (* we compute terms and atoms to consider for congruence *) + let repr_touched = List.map (fun (_,a,_) -> a) touched in + let st_others, sa_others = Use.congr_close_up env.use p repr_touched in + + (* we update use *) + let nuse = Use.up_close_up env.use p v in + Use.print nuse; + + (* we check the congruence of the terms. *) + let env = {env with use=nuse} in + let new_eqs = + SetT.fold (fun t l -> congruents env t st_others l ex) p_t l in + let touched_atoms = + List.map (fun (x,y,e)-> (LSem(A.Eq(x, y)), e)) touched + in + let touched_atoms = SetA.fold (fun (a, ex) acc -> + (LTerm a, ex)::acc) p_a touched_atoms in + let touched_atoms = SetA.fold (fun (a, ex) acc -> + (LTerm a, ex)::acc) sa_others touched_atoms in + env, new_eqs @ touched_atoms + + ) ({env with uf=uf}, []) res + + let replay_atom env sa = + let relation, result = X.Rel.assume env.relation sa in + let env = { env with relation = relation } in + let env = clean_use env result.remove in + env, result.assume + + let rec add_term env choices t ex = + (* nothing to do if the term already exists *) + if Uf.mem env.uf t then env, choices + else begin + Print.add_to_use t; + (* we add t's arguments in env *) + let {T.f = f; xs = xs} = T.view t in + let env, choices = + List.fold_left (fun (env, ch) t -> add_term env ch t ex) + (env, choices) xs + in + (* we update uf and use *) + let nuf, ctx = Uf.add env.uf t in + Print.make_cst t ctx; + let rt, _ = Uf.find nuf t in (* XXX : ctx only in terms *) + + if !cc_active then + let lvs = concat_leaves nuf xs in + let nuse = Use.up_add env.use t rt lvs in + + (* If finitetest is used we add the term to the relation *) + let rel = X.Rel.add env.relation rt in + Use.print nuse; + + (* we compute terms to consider for congruence *) + (* we do this only for non-atomic terms with uninterpreted head-symbol *) + let st_uset = Use.congr_add nuse lvs in + + (* we check the congruence of each term *) + let env = {uf = nuf; use = nuse; relation = rel} in + let ct = congruents env t st_uset [] ex in + let ct = (List.map (fun lt -> LTerm lt, ex) ctx) @ ct in + assume_literal env choices ct + else + let rel = X.Rel.add env.relation rt in + let env = {env with uf = nuf; relation = rel} in + env, choices + end + + and add env choices a ex = + match A.LT.view a with + | A.Eq (t1, t2) -> + let env, choices = add_term env choices t1 ex in + add_term env choices t2 ex + | A.Distinct (_, lt) + | A.Builtin (_, _, lt) -> + let env, choices = List.fold_left + (fun (env, ch) t-> add_term env ch t ex) (env, choices) lt in + let lvs = concat_leaves env.uf lt in (* A verifier *) + let env = List.fold_left + (fun env rx -> + let st, sa = Use.find rx env.use in + { env with + use = Use.add rx (st,SetA.add (a, ex) sa) env.use } + ) env lvs + in + env, choices + + and semantic_view env choices la = + List.fold_left + (fun (env, choices, lsa) (a, ex) -> + match a with + | LTerm a -> + let env, choices = add env choices a ex in + let sa, ex = term_canonical_view env a ex in + env, choices, (sa, Some a, ex)::lsa + + (* XXX si on fait canonical_view pour + A.Distinct, la theorie des tableaux + part dans les choux *) + | LSem (A.Builtin _ (*| A.Distinct _*) as sa) -> + let sa, ex = canonical_view env sa ex in + env, choices, (sa, None, ex)::lsa + | LSem sa -> + env, choices, (sa, None, ex)::lsa) + (env, choices, []) la + + and assume_literal env choices la = + if la = [] then env, choices + else + let env, choices, lsa = semantic_view env choices la in + let env, choices = + List.fold_left + (fun (env, choices) (sa, _, ex) -> + Print.assume_literal sa; + match sa with + | A.Eq(r1, r2) -> + if !cc_active then + let env, l = congruence_closure env r1 r2 ex in + let env, choices = assume_literal env choices l in + let env, choices = + assume_literal env choices (contra_congruence env r1 ex) + in + assume_literal env choices (contra_congruence env r2 ex) + else + {env with uf = fst(Uf.union env.uf r1 r2 ex)}, choices + | A.Distinct (false, lr) -> + if Uf.already_distinct env.uf lr then env, choices + else + {env with uf = Uf.distinct env.uf lr ex}, choices + | A.Distinct (true, _) -> assert false + | A.Builtin _ -> env, choices) + (env, choices) lsa + in + let env, l = replay_atom env lsa in + assume_literal env (choices@l) l + + let look_for_sat ?(bad_last=No) ch t base_env l = + let rec aux ch bad_last dl base_env li = + match li, bad_last with + | [], _ -> + begin + match X.Rel.case_split base_env.relation with + | [] -> + { t with gamma_finite = base_env; choices = List.rev dl }, ch + | l -> + let l = + List.map + (fun (c, ex_c, size) -> + let exp = Ex.fresh_exp () in + let ex_c_exp = Ex.add_fresh exp ex_c in + (* A new explanation in order to track the choice *) + (c, size, CPos exp, ex_c_exp)) l in + let sz = + List.fold_left + (fun acc (a,s,_,_) -> + Num.mult_num acc s) (Num.Int 1) (l@dl) in + Print.split_size sz; + if Num.le_num sz max_split then aux ch No dl base_env l + else + { t with gamma_finite = base_env; choices = List.rev dl }, ch + end + | ((c, size, CNeg, ex_c) as a)::l, _ -> + let base_env, ch = assume_literal base_env ch [LSem c, ex_c] in + aux ch bad_last (a::dl) base_env l + + (** This optimisation is not correct with the current explanation *) + (* | [(c, size, CPos exp, ex_c)], Yes dep -> *) + (* let neg_c = LR.neg (LR.make c) in *) + (* let ex_c = Ex.union ex_c dep in *) + (* Print.split_backtrack neg_c ex_c; *) + (* aux ch No dl base_env [LR.view neg_c, Num.Int 1, CNeg, ex_c] *) + + | ((c, size, CPos exp, ex_c_exp) as a)::l, _ -> + try + Print.split_assume (LR.make c) ex_c_exp; + let base_env, ch = assume_literal base_env ch [LSem c, ex_c_exp] in + aux ch bad_last (a::dl) base_env l + with Exception.Inconsistent dep -> + match Ex.remove_fresh exp dep with + | None -> + (* The choice doesn't participate to the inconsistency *) + Print.split_backjump (LR.make c) dep; + raise (Exception.Inconsistent dep) + | Some dep -> + (* The choice participates to the inconsistency *) + let neg_c = LR.neg (LR.make c) in + Print.split_backtrack neg_c dep; + aux ch No dl base_env [LR.view neg_c, Num.Int 1, CNeg, dep] + in + aux ch bad_last (List.rev t.choices) base_env l + + let try_it f t = + Print.begin_case_split (); + let r = + try + if t.choices = [] then look_for_sat [] t t.gamma [] + else + try + let env, lt = f t.gamma_finite in + look_for_sat lt t env [] + with Exception.Inconsistent dep -> + look_for_sat ~bad_last:(Yes dep) + [] { t with choices = []} t.gamma t.choices + with Exception.Inconsistent d -> + Print.end_case_split (); + raise (Exception.Inconsistent d) + in + Print.end_case_split (); r + + let extract_from_semvalues = + List.fold_left + (fun acc r -> + match X.term_extract r with Some t -> SetT.add t acc | _ -> acc) + + let extract_terms_from_choices = + List.fold_left + (fun acc (a, _, _, _) -> + match a with + | A.Eq(r1, r2) -> extract_from_semvalues acc [r1; r2] + | A.Distinct (_, l) -> extract_from_semvalues acc l + | _ -> acc) + + let extract_terms_from_assumed = + List.fold_left + (fun acc (a, _) -> + match a with + | LTerm r -> begin + match Literal.LT.view r with + | Literal.Eq (t1, t2) -> + SetT.add t1 (SetT.add t2 acc) + | Literal.Distinct (_, l) | Literal.Builtin (_, _, l) -> + List.fold_right SetT.add l acc + end + | _ -> acc) + + let assume ~cs a ex t = + let a = LTerm a in + let gamma, ch = assume_literal t.gamma [] [a, ex] in + let t = { t with gamma = gamma } in + let t, ch = + if cs then try_it (fun env -> assume_literal env ch [a, ex] ) t + else t, ch + in + let choices = extract_terms_from_choices SetT.empty t.choices in + let all_terms = extract_terms_from_assumed choices ch in + t, all_terms, 1 + + let class_of t term = Uf.class_of t.gamma.uf term + + let add_and_process a t = + let aux a ex env = + let gamma, l = add env [] a ex in assume_literal gamma [] l + in + let gamma, _ = aux a Ex.empty t.gamma in + let t = { t with gamma = gamma } in + let t, _ = try_it (aux a Ex.empty) t in + Use.print t.gamma.use; t + + let query a t = + Print.query a; + try + match A.LT.view a with + | A.Eq (t1, t2) -> + let t = add_and_process a t in + Uf.are_equal t.gamma.uf t1 t2 + + | A.Distinct (false, [t1; t2]) -> + let na = A.LT.neg a in + let t = add_and_process na t in (* na ? *) + Uf.are_distinct t.gamma.uf t1 t2 + + | A.Distinct _ -> + assert false (* devrait etre capture par une analyse statique *) + + | _ -> + let na = A.LT.neg a in + let t = add_and_process na t in + let env = t.gamma in + let rna, ex_rna = term_canonical_view env na Ex.empty in + X.Rel.query env.relation (rna, Some na, ex_rna) + with Exception.Inconsistent d -> Yes d + + let empty () = + let env = { + use = Use.empty ; + uf = Uf.empty ; + relation = X.Rel.empty (); + } + in + let t = { gamma = env; gamma_finite = env; choices = [] } in + let t, _, _ = + assume ~cs:false + (A.LT.make (A.Distinct (false, [T.vrai; T.faux]))) Ex.empty t + in t + +end diff --git a/smt/cc.mli b/smt/cc.mli new file mode 100644 index 00000000..3812b7fb --- /dev/null +++ b/smt/cc.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Evelyne Contejean *) +(* Francois Bobot, Mohamed Iguernelala, Alain Mebsout *) +(* CNRS, Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +val cc_active : bool ref + +module type S = sig + type t + + module TimerCC : Timer.S + + val empty : unit -> t + val assume : cs:bool -> + Literal.LT.t -> Explanation.t -> t -> t * Term.Set.t * int + val query : Literal.LT.t -> t -> Sig.answer + val class_of : t -> Term.t -> Term.t list +end + +module Make (X:Sig.X) : S diff --git a/smt/combine.ml b/smt/combine.ml new file mode 100644 index 00000000..e9fafcc6 --- /dev/null +++ b/smt/combine.ml @@ -0,0 +1,253 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format +open Sig + +module rec CX : sig + include Sig.X + + val extract1 : r -> X1.t option + val embed1 : X1.t -> r + + val extract5 : r -> X5.t option + val embed5 : X5.t -> r + +end = +struct + + type r = + | Term of Term.t + | X1 of X1.t + | X5 of X5.t + + let extract1 = function X1 r -> Some r | _ -> None + let extract5 = function X5 r -> Some r | _ -> None + + let embed1 x = X1 x + let embed5 x = X5 x + + let is_int v = + let ty = match v with + | X1 x -> X1.type_info x + | X5 x -> X5.type_info x + | Term t -> (Term.view t).Term.ty + in + ty = Ty.Tint + + let rec compare a b = + let c = compare_tag a b in + if c = 0 then comparei a b else c + + and compare_tag a b = + Pervasives.compare (theory_num a) (theory_num b) + + and comparei a b = + match a, b with + | X1 x, X1 y -> X1.compare x y + | X5 x, X5 y -> X5.compare x y + | Term x , Term y -> Term.compare x y + | _ -> assert false + + and theory_num x = Obj.tag (Obj.repr x) + + let equal a b = compare a b = 0 + + let hash = function + | Term t -> Term.hash t + | X1 x -> X1.hash x + | X5 x -> X5.hash x + + module MR = Map.Make(struct type t = r let compare = compare end) + + let print fmt r = + match r with + | X1 t -> fprintf fmt "%a" X1.print t + | X5 t -> fprintf fmt "%a" X5.print t + | Term t -> fprintf fmt "%a" Term.print t + + let leaves r = + match r with + | X1 t -> X1.leaves t + | X5 t -> X5.leaves t + | Term _ -> [r] + + let term_embed t = Term t + + let term_extract r = + match r with + | X1 _ -> X1.term_extract r + | X5 _ -> X5.term_extract r + | Term t -> Some t + + let subst p v r = + if equal p v then r + else match r with + | X1 t -> X1.subst p v t + | X5 t -> X5.subst p v t + | Term _ -> if equal p r then v else r + + let make t = + let {Term.f=sb} = Term.view t in + match X1.is_mine_symb sb, X5.is_mine_symb sb with + | true, false -> X1.make t + | false, true -> X5.make t + | false, false -> Term t, [] + | _ -> assert false + + let fully_interpreted sb = + match X1.is_mine_symb sb, X5.is_mine_symb sb with + | true, false -> X1.fully_interpreted sb + | false, true -> X5.fully_interpreted sb + | false, false -> false + | _ -> assert false + + let add_mr = + List.fold_left + (fun solved (p,v) -> + MR.add p (v::(try MR.find p solved with Not_found -> [])) solved) + + let unsolvable = function + | X1 x -> X1.unsolvable x + | X5 x -> X5.unsolvable x + | Term _ -> true + + let partition tag = + List.partition + (fun (u,t) -> + (theory_num u = tag || unsolvable u) && + (theory_num t = tag || unsolvable t)) + + let rec solve_list solved l = + List.fold_left + (fun solved (a,b) -> + let cmp = compare a b in + if cmp = 0 then solved else + match a , b with + (* both sides are empty *) + | Term _ , Term _ -> + add_mr solved (unsolvable_values cmp a b) + + (* only one side is empty *) + | (a, b) + when unsolvable a || unsolvable b || compare_tag a b = 0 -> + let a,b = if unsolvable a then b,a else a,b in + let cp , sol = partition (theory_num a) (solvei b a) in + solve_list (add_mr solved cp) sol + + (* both sides are not empty *) + | a , b -> solve_theoryj solved a b + ) solved l + + and unsolvable_values cmp a b = + match a, b with + (* Clash entre theories: On peut avoir ces pbs ? *) + | X1 _, X5 _ + | X5 _, X1 _ + -> assert false + + (* theorie d'un cote, vide de l'autre *) + | X1 _, _ | _, X1 _ -> X1.solve a b + | X5 _, _ | _, X5 _ -> X5.solve a b + | Term _, Term _ -> [if cmp > 0 then a,b else b,a] + + and solve_theoryj solved xi xj = + let cp , sol = partition (theory_num xj) (solvei xi xj) in + solve_list (add_mr solved cp) (List.rev_map (fun (x,y) -> y,x) sol) + + and solvei a b = + match b with + | X1 _ -> X1.solve a b + | X5 _ -> X5.solve a b + | Term _ -> assert false + + let rec solve_rec mt ab = + let mr = solve_list mt ab in + let mr , ab = + MR.fold + (fun p lr ((mt,ab) as acc) -> match lr with + [] -> assert false + | [_] -> acc + | x::lx -> + MR.add p [x] mr , List.rev_map (fun y-> (x,y)) lx) + mr (mr,[]) + in + if ab = [] then mr else solve_rec mr ab + + let solve a b = + MR.fold + (fun p lr ret -> + match lr with [r] -> (p ,r)::ret | _ -> assert false) + (solve_rec MR.empty [a,b]) [] + + let rec type_info = function + | X1 t -> X1.type_info t + | X5 t -> X5.type_info t + | Term t -> let {Term.ty = ty} = Term.view t in ty + + module Rel = struct + type elt = r + type r = elt + + type t = { + r1: X1.Rel.t; + r5: X5.Rel.t; + } + + let empty _ = { + r1=X1.Rel.empty (); + r5=X5.Rel.empty (); + } + + let assume env sa = + let env1, { assume = a1; remove = rm1} = X1.Rel.assume env.r1 sa in + let env5, { assume = a5; remove = rm5} = X5.Rel.assume env.r5 sa in + {r1=env1; r5=env5}, + { assume = a1@a5; remove = rm1@rm5;} + + let query env a = + match X1.Rel.query env.r1 a with + | Yes _ as ans -> ans + | No -> X5.Rel.query env.r5 a + + let case_split env = + let seq1 = X1.Rel.case_split env.r1 in + let seq5 = X5.Rel.case_split env.r5 in + seq1 @ seq5 + + let add env r = + {r1=X1.Rel.add env.r1 r; + r5=X5.Rel.add env.r5 r } + end + +end + +and TX1 : Polynome.T with type r = CX.r = Arith.Type(CX) + +and X1 : Sig.THEORY with type t = TX1.t and type r = CX.r = + Arith.Make(CX)(TX1) + (struct + type t = TX1.t + type r = CX.r + let extract = CX.extract1 + let embed = CX.embed1 + let assume env _ _ = env, {Sig.assume = []; remove = []} + end) + +and X5 : Sig.THEORY with type r = CX.r and type t = CX.r Sum.abstract = + Sum.Make + (struct + include CX + let extract = extract5 + let embed = embed5 + end) diff --git a/smt/combine.mli b/smt/combine.mli new file mode 100644 index 00000000..8570a377 --- /dev/null +++ b/smt/combine.mli @@ -0,0 +1,14 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module CX : Sig.X diff --git a/smt/exception.ml b/smt/exception.ml new file mode 100644 index 00000000..b0a38d72 --- /dev/null +++ b/smt/exception.ml @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +exception Unsolvable +exception Inconsistent of Explanation.t +exception Progress +exception NotCongruent +exception Trivial +exception Interpreted_Symbol diff --git a/smt/exception.mli b/smt/exception.mli new file mode 100644 index 00000000..b0a38d72 --- /dev/null +++ b/smt/exception.mli @@ -0,0 +1,19 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +exception Unsolvable +exception Inconsistent of Explanation.t +exception Progress +exception NotCongruent +exception Trivial +exception Interpreted_Symbol diff --git a/smt/explanation.ml b/smt/explanation.ml new file mode 100644 index 00000000..d1cbf410 --- /dev/null +++ b/smt/explanation.ml @@ -0,0 +1,69 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Stephane Lescuyer *) +(* INRIA, Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Solver_types +open Format + +type exp = Atom of Solver_types.atom | Fresh of int + +module S = + Set.Make + (struct + type t = exp + let compare a b = match a,b with + | Atom _, Fresh _ -> -1 + | Fresh _, Atom _ -> 1 + | Fresh i1, Fresh i2 -> i1 - i2 + | Atom a, Atom b -> a.aid - b.aid + end) + +type t = S.t + +let singleton e = S.singleton (Atom e) + +let empty = S.empty + +let union s1 s2 = S.union s1 s2 + +let iter_atoms f s = + S.iter (fun e -> match e with + | Fresh _ -> () + | Atom a -> f a) s + +let fold_atoms f s acc = + S.fold (fun e acc -> match e with + | Fresh _ -> acc + | Atom a -> f a acc) s acc + +let merge e1 e2 = e1 + + +let fresh_exp = + let r = ref (-1) in + fun () -> incr r; !r + +let remove_fresh i s = + let fi = Fresh i in + if S.mem fi s then Some (S.remove fi s) + else None + +let add_fresh i = S.add (Fresh i) + + +let print fmt ex = + fprintf fmt "{"; + S.iter (function + | Atom a -> fprintf fmt "%a, " Debug.atom a + | Fresh i -> fprintf fmt "Fresh%d " i) ex; + fprintf fmt "}" diff --git a/smt/explanation.mli b/smt/explanation.mli new file mode 100644 index 00000000..5a0e0db9 --- /dev/null +++ b/smt/explanation.mli @@ -0,0 +1,37 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Stephane Lescuyer *) +(* INRIA, Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type t + +type exp + +val empty : t + +val singleton : Solver_types.atom -> t + +val union : t -> t -> t + +val merge : t -> t -> t + +val iter_atoms : (Solver_types.atom -> unit) -> t -> unit + +val fold_atoms : (Solver_types.atom -> 'a -> 'a ) -> t -> 'a -> 'a + +val fresh_exp : unit -> int + +val remove_fresh : int -> t -> t option + +val add_fresh : int -> t -> t + +val print : Format.formatter -> t -> unit diff --git a/smt/fm.ml b/smt/fm.ml new file mode 100644 index 00000000..53fc3669 --- /dev/null +++ b/smt/fm.ml @@ -0,0 +1,806 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Num +open Format +open Sig + +let ale = Hstring.make "<=" +let alt = Hstring.make "<" +let is_le n = Hstring.compare n ale = 0 +let is_lt n = Hstring.compare n alt = 0 + +let (-@) l1 l2 = List.rev_append l1 l2 + +module L = Literal +module Sy = Symbols + +exception NotConsistent of Literal.LT.Set.t + +module type EXTENDED_Polynome = sig + include Polynome.T + val poly_of : r -> t + val alien_of : t -> r +end + +module Make + (X : Sig.X) + (P : EXTENDED_Polynome with type r = X.r) = struct + + module MP = Map.Make(P) + module SP = Set.Make(P) + module SX = Set.Make(struct type t = X.r include X end) + module MX = Map.Make(struct type t = X.r include X end) + + type r = P.r + + module LR = Literal.Make(struct type t = X.r include X end) + + module Seq = + Set.Make + (struct + type t = r L.view * L.LT.t option * Explanation.t + let compare (a, _, _) (b, _, _) = + LR.compare (LR.make a) (LR.make b) + end) + + module Inequation = struct + type t = { + ple0 : P.t; + is_le : bool; + dep : (Literal.LT.t * num * P.t * bool) list; + expl : Explanation.t + } + + let print fmt ineq = fprintf fmt "%a %s 0" P.print ineq.ple0 + (if ineq.is_le then "<=" else "<") + + let create p1 p2 is_le a expl = + let p = P.add p1 (P.mult (P.create [] (Int (-1)) (P.type_info p1)) p2) in + { ple0 = p; is_le = is_le; dep = [a, Int 1, p, is_le]; expl = expl } + + let choose ineq = snd (P.choose ineq.ple0) + + let find x ineq = P.find x ineq.ple0 + + let is_monomial ineq = P.is_monomial ineq.ple0 + + let pos_neg mx { ple0 = p } = + List.fold_left (fun m (c,x) -> + let cmp = compare_num c (Int 0) in + if cmp = 0 then m + else + let (pos, neg) = try MX.find x m with Not_found -> (0,0) in + if cmp > 0 then MX.add x (pos+1, neg) m + else MX.add x (pos, neg+1) m ) mx (fst (P.to_list p)) + + end + + type t = { + inequations : (Literal.LT.t * Inequation.t) list ; + monomes: (Intervals.t * SX.t) MX.t; + polynomes : Intervals.t MP.t; + known_eqs : SX.t; + improved : SP.t; + } + + module Debug = struct + + let list_of_ineqs fmt = List.iter (fprintf fmt "%a " Inequation.print) + + let assume a = () + + let cross x cpos cneg others ninqs = () + + let print_use fmt use = + SX.iter (fprintf fmt "%a, " X.print) use + + let env env = () + + let implied_equalities l = () + end + + let empty _ = { + inequations = [] ; + monomes = MX.empty ; + polynomes = MP.empty ; + known_eqs = SX.empty ; + improved = SP.empty ; + } + + let replace_inequation env x ineq = + { env with + inequations = (x, ineq)::(List.remove_assoc x env.inequations) } + + + let up_improved env p oldi newi = + if Intervals.is_strict_smaller newi oldi then + { env with improved = SP.add p env.improved } + else env + +(* + let oldify_inequations env = + { env with + inequations = env.inequations@env.new_inequations; + new_inequations = [] } *) + + let mult_bornes_vars vars monomes ty= + List.fold_left + (fun ui (y,n) -> + let ui' = try + fst (MX.find y monomes) + with Not_found -> Intervals.undefined ty + in + Intervals.mult ui (Intervals.power n ui') + ) (Intervals.point (Int 1) ty Explanation.empty) vars + + + let intervals_from_monomes env p = + let pl, v = P.to_list p in + List.fold_left + (fun i (a, x) -> + let i_x, _ = MX.find x env.monomes in + Intervals.add (Intervals.scale a i_x) i + ) (Intervals.point v (P.type_info p) Explanation.empty) pl + + let rec add_monome expl use_x env x = + try + let u, old_use_x = MX.find x env.monomes in + { env with monomes = MX.add x (u, SX.union old_use_x use_x) env.monomes } + with Not_found -> + update_monome expl use_x env x + + and init_monomes env p use_p expl = + List.fold_left + (fun env (_, x) -> add_monome expl use_p env x) + env (fst (P.to_list p)) + + and init_alien expl p (normal_p, c, d) ty use_x env = + let env = init_monomes env p use_x expl in + let i = intervals_from_monomes env p in + let i = + try + let old_i = MP.find normal_p env.polynomes in + let old_i = Intervals.scale d + (Intervals.add old_i (Intervals.point c ty Explanation.empty)) in + Intervals.intersect i old_i + with Not_found -> i + in + env, i + + + + and update_monome expl use_x env x = + let ty = X.type_info x in + let ui, env = + match X.term_extract x with + | Some t -> + let use_x = SX.singleton x in + begin + match Term.view t with + | {Term.f = (Sy.Op Sy.Div); xs = [a; b]} -> + let pa = P.poly_of (fst (X.make a)) in + let pb = P.poly_of (fst (X.make b)) in + let (pa', ca, da) as npa = P.normal_form_pos pa in + let (pb', cb, db) as npb = P.normal_form_pos pb in + let env, ia = init_alien expl pa npa ty use_x env in + let env, ib = init_alien expl pb npb ty use_x env in + let ia, ib = match Intervals.doesnt_contain_0 ib with + | Yes ex when Num.compare_num ca cb = 0 + && P.compare pa' pb' = 0 -> + let expl = Explanation.union ex expl in + Intervals.point da ty expl, Intervals.point db ty expl + | _ -> ia, ib + in + Intervals.div ia ib, env + | _ -> Intervals.undefined ty, env + end + | _ -> Intervals.undefined ty, env + in + let u, use_x' = + try MX.find x env.monomes + with Not_found -> Intervals.undefined (X.type_info x), use_x in + let ui = Intervals.intersect ui u in + { env with monomes = MX.add x (ui, (SX.union use_x use_x')) env.monomes } + + and tighten_div x env expl = env + + and tighten_non_lin x use_x env expl = + let env = tighten_div x env expl in + SX.fold + (fun x acc -> + let _, use = MX.find x acc.monomes in + update_monome expl use acc x) + use_x env + + let update_monomes_from_poly p i polynomes monomes = + let lp, _ = P.to_list p in + let ty = P.type_info p in + List.fold_left (fun monomes (a,x) -> + let np = P.remove x p in + let (np,c,d) = P.normal_form_pos np in + try + let inp = MP.find np polynomes in + let new_ix = + Intervals.scale + ((Int 1) // a) + (Intervals.add i + (Intervals.scale (minus_num d) + (Intervals.add inp + (Intervals.point c ty Explanation.empty)))) in + let old_ix, ux = MX.find x monomes in + let ix = Intervals.intersect old_ix new_ix in + MX.add x (ix, ux) monomes + with Not_found -> monomes) + monomes lp + + let update_polynomes env expl = + let polynomes, monomes, improved = MP.fold + (fun p ip (polynomes, monomes, improved) -> + let new_i = intervals_from_monomes env p in + let i = Intervals.intersect new_i ip in + if Intervals.is_strict_smaller i ip then + let monomes = update_monomes_from_poly p i polynomes monomes in + let improved = SP.add p improved in + MP.add p i polynomes, monomes, improved + else polynomes, monomes, improved + ) env.polynomes (env.polynomes, env.monomes, env.improved) in + {env with polynomes = polynomes; monomes = monomes ; improved = improved} + + + let find_one_eq x u = + match Intervals.is_point u with + | Some (v, ex) when X.type_info x <> Ty.Tint or is_integer_num v -> + let eq = + L.Eq (x,(P.alien_of (P.create [] v (X.type_info x)))) in + Some (eq, None, ex) + | _ -> None + + let find_eq eqs x u env = + match find_one_eq x u with + | None -> eqs + | Some eq1 -> eq1::eqs + + type ineq_status = + | Trivial_eq + | Trivial_ineq of num + | Bottom + | Monome of num * P.r * num + | Other + + let ineq_status ({Inequation.ple0 = p ; is_le = is_le} as ineq) = + match Inequation.is_monomial ineq with + Some (a, x, v) -> Monome (a, x, v) + | None -> + if P.is_empty p then + let _, v = P.to_list p in + let c = compare_num v (Int 0) in + if c > 0 || (c >=0 && not is_le) then Bottom + else + if c = 0 && is_le then Trivial_eq + else Trivial_ineq v + else Other + + (*let ineqs_from_dep dep borne_inf is_le = + List.map + (fun {poly_orig = p; coef = c} -> + let (m,v,ty) = P.mult_const minusone p in + (* quelle valeur pour le ?????? *) + { ple0 = {poly = (m, v +/ (borne_inf // c), ty); le = is_le} ; + dep = []} + )dep*) + + let mk_equality p = + let r1 = P.alien_of p in + let r2 = P.alien_of (P.create [] (Int 0) (P.type_info p)) in + L.Eq (r1, r2) + + let fm_equalities env eqs { Inequation.ple0 = p; dep = dep; expl = ex } = + let inqs, eqs = + List.fold_left + (fun (inqs, eqs) (a, _, p, _) -> + List.remove_assoc a inqs, (mk_equality p, Some a, ex) :: eqs + ) (env.inequations, eqs) dep + in + { env with inequations = inqs }, eqs + + let update_intervals env eqs expl (a, x, v) is_le = + let uints, use_x = MX.find x env.monomes in + let b = ((Int (-1)) */ v) // a in + let u = + if a >/ (Int 0) then + Intervals.new_borne_sup expl b is_le uints + else + Intervals.new_borne_inf expl b is_le uints in + let env = { env with monomes = MX.add x (u, use_x) env.monomes } in + let env = tighten_non_lin x use_x env expl in + env, (find_eq eqs x u env) + + let update_ple0 env p0 is_le expl = + if P.is_empty p0 then env + else + let ty = P.type_info p0 in + let a, _ = P.choose p0 in + let p, change = + if a u, Intervals.undefined ty + in + let env = + if Intervals.is_strict_smaller u pu then + let polynomes = MP.add p u env.polynomes in + let monomes = update_monomes_from_poly p u polynomes env.monomes in + let improved = SP.add p env.improved in + { env with + polynomes = polynomes; + monomes = monomes; + improved = improved } + else env + in + match P.to_list p0 with + | [a,x], v -> fst(update_intervals env [] expl (a, x, v) is_le) + | _ -> env + + let add_inequations acc lin expl = + List.fold_left + (fun (env, eqs) ineq -> + (* let expl = List.fold_left + (fun expl (l,_,_,_) -> + Explanation.union (*Explanation.everything*) + (Explanation.singleton (Formula.mk_lit l)) + expl + ) expl ineq.Inequation.dep + in *) + let expl = Explanation.union ineq.Inequation.expl expl in + match ineq_status ineq with + | Bottom -> + raise (Exception.Inconsistent expl) + + | Trivial_eq -> + fm_equalities env eqs ineq + + | Trivial_ineq c -> + let n, pp = + List.fold_left + (fun ((n, pp) as acc) (_, _, p, is_le) -> + if is_le then acc else + match pp with + | Some _ -> n+1, None + | None when n=0 -> 1, Some p + | _ -> n+1, None) (0,None) ineq.Inequation.dep + in + let env = + List.fold_left + (fun env (_, coef, p, is_le) -> + let ty = P.type_info p in + let is_le = + match pp with + Some x -> P.compare x p = 0 | _ -> is_le && n=0 + in + let p' = P.sub (P.create [] (c // coef) ty) p in + update_ple0 env p' is_le expl + ) env ineq.Inequation.dep + in + env, eqs + + | Monome (a, x, v) -> + let env, eqs = + update_intervals env eqs expl (a, x, v) ineq.Inequation.is_le + in + + (*let env,eqs = update_bornes env eqs ((a,x),c) ineq.ple0.le in + let env,eqs = update_polynomes env eqs ineq in + env, pers_ineqs, eqs*) + env, eqs + + | Other -> + env, eqs + (*t env,eqs = update_polynomes env eqs ineq in + env, pers_ineqs, eqs*) + + + ) acc lin + + let mult_list c = + List.map (fun (a, coef, p, is_le) -> (a, coef */ c, p, is_le)) + + let div_by_pgcd (a, b) ty = + try + if ty = Ty.Tint then + let p = Big_int.gcd_big_int (big_int_of_num a) (big_int_of_num b) in + let p = num_of_big_int p in + a // p, b // p + else a, b + with Failure "big_int_of_ratio" -> a, b + + let cross x cpos cneg = + let rec cross_rec acc = function + | [] -> acc + | { Inequation.ple0 = p1; is_le = k1; dep = d1; expl = ex1 } :: l -> + let n1 = abs_num (P.find x p1) in + (* let ty = P.type_info p1 in *) + let acc = + List.fold_left + (fun acc {Inequation.ple0 = p2; is_le = k2; dep=d2; expl = ex2} -> + let n2 = abs_num (P.find x p2) in + (* let n1, n2 = div_by_pgcd (n1, n2) ty in *) + let p = P.add + (P.mult (P.create [] n2 (P.type_info p2)) p1) + (P.mult (P.create [] n1 (P.type_info p1)) p2) in + let d1 = mult_list n2 d1 in + let d2 = mult_list n1 d2 in + let ni = + { Inequation.ple0 = p; is_le = k1&&k2; dep = d1 -@ d2; + expl = Explanation.union ex1 ex2 } + in + ni::acc + ) acc cpos + in + cross_rec acc l + in + cross_rec [] cneg + + let split x l = + let rec split_rec (cp, cn, co) ineq = + try + let a = Inequation.find x ineq in + if a >/ (Int 0) then ineq::cp, cn, co + else cp, ineq::cn, co + with Not_found -> cp, cn, ineq::co + in + List.fold_left split_rec ([], [], []) l + + let length s = SX.fold (fun _ acc -> acc+1) s 0 + + let choose_var l = + let pos_neg = List.fold_left Inequation.pos_neg MX.empty l in + let xopt = MX.fold (fun x (pos, neg) acc -> + match acc with + | None -> Some (x, pos * neg) + | Some (y, c') -> + let c = pos * neg in + if c < c' then Some (x, c) else acc + ) pos_neg None in + match xopt with + | Some (x, _) -> x + | None -> raise Not_found + + let rec fourier ( (env, eqs) as acc) l expl = + match l with + | [] -> acc + | ineq :: l' -> + try + (* let x = Inequation.choose ineq in *) + let x = choose_var l in + let cpos, cneg, others = split x l in + let ninqs = cross x cpos cneg in + Debug.cross x cpos cneg others ninqs; + let acc = add_inequations acc cpos expl in + let acc = add_inequations acc cneg expl in + fourier acc (ninqs -@ others) expl + with Not_found -> add_inequations acc l expl + + (* + let fm env eqs expl = + fourier (env, eqs) + (List.map snd env.inequations) + (List.map snd env.new_inequations) expl +*) + + let fm env eqs expl = + fourier (env, eqs) (List.map snd env.inequations) expl + + let is_num r = + let ty = X.type_info r in ty = Ty.Tint || ty = Ty.Treal + + let add_disequality env eqs p expl = + let ty = P.type_info p in + match P.to_list p with + | ([], (Int 0)) -> + raise (Exception.Inconsistent expl) + | ([], v) -> + env, eqs + | ([a, x], v) -> + let b = (minus_num v) // a in + let i1 = Intervals.point b ty expl in + let i2, use2 = + try + MX.find x env.monomes + with Not_found -> Intervals.undefined ty, SX.empty + in + let i = Intervals.exclude i1 i2 in + let env ={ env with monomes = MX.add x (i,use2) env.monomes } in + let env = tighten_non_lin x use2 env expl in + env, find_eq eqs x i env + | _ -> + let a, _ = P.choose p in + let p = if a >=/ Int 0 then p + else P.mult (P.create [] (Int (-1)) ty) p in + let p, c, _ = P.normal_form p in + let i1 = Intervals.point (minus_num c) ty expl in + let i2 = + try + MP.find p env.polynomes + with Not_found -> Intervals.undefined ty + in + let i = Intervals.exclude i1 i2 in + let env = + if Intervals.is_strict_smaller i i2 then + let polynomes = MP.add p i env.polynomes in + let monomes = update_monomes_from_poly p i polynomes env.monomes + in + let improved = SP.add p env.improved in + { env with + polynomes = polynomes; + monomes = monomes; + improved = improved} + else env + in + env, eqs + + let add_equality env eqs p expl = + let ty = P.type_info p in + match P.to_list p with + | ([], Int 0) -> env, eqs + | ([], v) -> + raise (Exception.Inconsistent expl) + | ([a, x], v) -> + let b = (minus_num v) // a in + let i = Intervals.point b ty expl in + let i, use = + try + let i', use' = MX.find x env.monomes in + Intervals.intersect i i', use' + with Not_found -> i, SX.empty + in + let env = { env with monomes = MX.add x (i, use) env.monomes} in + let env = tighten_non_lin x use env expl in + env, find_eq eqs x i env + | _ -> + let a, _ = P.choose p in + let p = if a >=/ Int 0 then p + else P.mult (P.create [] (Int (-1)) ty) p in + let p, c, _ = P.normal_form p in + let i = Intervals.point (minus_num c) ty expl in + let i, ip = + try + let ip = MP.find p env.polynomes in + Intervals.intersect i ip, ip + with Not_found -> i, Intervals.undefined ty + in + let env = + if Intervals.is_strict_smaller i ip then + let polynomes = MP.add p i env.polynomes in + let monomes = update_monomes_from_poly p i polynomes env.monomes + in + let improved = SP.add p env.improved in + { env with + polynomes = polynomes; + monomes = monomes; + improved = improved } + else env + in + let env = + { env with + known_eqs = SX.add (P.alien_of p) env.known_eqs + } in + env, eqs + + let normal_form a = match a with + | L.Builtin (false, n, [r1; r2]) when is_le n && X.type_info r1 = Ty.Tint -> + let pred_r1 = P.sub (P.poly_of r1) (P.create [] (Int 1) Ty.Tint) in + L.Builtin (true, n, [r2; P.alien_of pred_r1]) + + | L.Builtin (true, n, [r1; r2]) when + not (is_le n) && X.type_info r1 = Ty.Tint -> + let pred_r2 = P.sub (P.poly_of r2) (P.create [] (Int 1) Ty.Tint) in + L.Builtin (true, ale, [r1; P.alien_of pred_r2]) + + | L.Builtin (false, n, [r1; r2]) when is_le n -> + L.Builtin (true, alt, [r2; r1]) + + | L.Builtin (false, n, [r1; r2]) when is_lt n -> + L.Builtin (true, ale, [r2; r1]) + + | _ -> a + + let remove_trivial_eqs eqs la = + let set_of l = + List.fold_left (fun s e -> Seq.add e s) Seq.empty l + in + Seq.elements (Seq.diff (set_of eqs) (set_of la)) + + + let equalities_from_polynomes env eqs = + let known, eqs = + MP.fold + (fun p i (knw, eqs) -> + let xp = P.alien_of p in + if SX.mem xp knw then knw, eqs + else + match Intervals.is_point i with + | Some (num, ex) -> + let r2 = P.alien_of (P.create [] num (P.type_info p)) in + SX.add xp knw, (L.Eq(xp, r2), None, ex) :: eqs + | None -> knw, eqs + ) env.polynomes (env.known_eqs, eqs) + in {env with known_eqs= known}, eqs + + + + let equalities_from_monomes env eqs = + let known, eqs = + MX.fold + (fun x (i,_) (knw, eqs) -> + if SX.mem x knw then knw, eqs + else + match Intervals.is_point i with + | Some (num, ex) -> + let r2 = P.alien_of (P.create [] num (X.type_info x)) in + SX.add x knw, (L.Eq(x, r2), None, ex) :: eqs + | None -> knw, eqs + ) env.monomes (env.known_eqs, eqs) + in {env with known_eqs= known}, eqs + + let equalities_from_intervals env eqs = + let env, eqs = equalities_from_polynomes env eqs in + equalities_from_monomes env eqs + + let assume env la = + let env = {env with improved = SP.empty} in + Debug.env env; + let env, eqs, new_ineqs, expl = + List.fold_left + (fun (env, eqs, new_ineqs, expl) (a, root, e) -> + let a = normal_form a in + let expl = Explanation.union e expl in + try + match a with + | L.Builtin(_, n, [r1;r2]) when is_le n || is_lt n -> + let root = match root with + | Some a -> a | None -> assert false in + let p1 = P.poly_of r1 in + let p2 = P.poly_of r2 in + let ineq = Inequation.create p1 p2 (is_le n) root expl in + let env = + init_monomes env ineq.Inequation.ple0 SX.empty expl in + let env = + update_ple0 env ineq.Inequation.ple0 (is_le n) expl in + let env = replace_inequation env root ineq in + env, eqs, true, expl + + | L.Distinct (false, [r1; r2]) when is_num r1 && is_num r2 -> + let p = P.sub (P.poly_of r1) (P.poly_of r2) in + let env = init_monomes env p SX.empty expl in + let env, eqs = add_disequality env eqs p expl in + env, eqs, new_ineqs, expl + + | L.Eq(r1, r2) when is_num r1 && is_num r2 -> + let p = P.sub (P.poly_of r1) (P.poly_of r2) in + let env = init_monomes env p SX.empty expl in + let env, eqs = add_equality env eqs p expl in + env, eqs, new_ineqs, expl + + | _ -> (env, eqs, new_ineqs, expl) + + with Intervals.NotConsistent expl -> + raise (Exception.Inconsistent expl) + ) + (env, [], false, Explanation.empty) la + + in + if new_ineqs then + if false then + (); + try + (* we only call fm when new ineqs are assumed *) + let env, eqs = if new_ineqs then fm env eqs expl else env, eqs in + (* let env = oldify_inequations env in *) + let env = update_polynomes env expl in + let env, eqs = equalities_from_intervals env eqs in + Debug.env env; + let eqs = remove_trivial_eqs eqs la in + Debug.implied_equalities eqs; + let result = + List.fold_left + (fun r (a_sem, a_term, ex) -> + { assume = (LSem(a_sem), ex) :: r.assume; + remove = + match a_term with + | None -> r.remove + | Some t -> (LTerm(t), ex)::r.remove + } ) { assume = []; remove = [] } eqs + in + env, result + + with Intervals.NotConsistent expl -> + raise (Exception.Inconsistent expl) + + let query env a_ex = + try + ignore(assume env [a_ex]); + No + with Exception.Inconsistent expl -> Yes expl + + let case_split_polynomes env = + let o = MP.fold + (fun p i o -> + match Intervals.finite_size i with + | Some s when s >/ (Int 1) -> + begin + match o with + | Some (s', _, _, _) when s' <=/ s -> o + | _ -> + let n, ex = Intervals.borne_inf i in + Some (s, p, n, ex) + end + | _ -> o + ) env.polynomes None in + match o with + | Some (s, p, n, ex) -> + let r1 = P.alien_of p in + let r2 = P.alien_of (P.create [] n (P.type_info p)) in + [L.Eq(r1, r2), ex, s] + | None -> + [] + + let case_split_monomes env = + let o = MX.fold + (fun x (i,_) o -> + match Intervals.finite_size i with + | Some s when s >/ (Int 1) -> + begin + match o with + | Some (s', _, _, _) when s' <=/ s -> o + | _ -> + let n, ex = Intervals.borne_inf i in + Some (s, x, n, ex) + end + | _ -> o + ) env.monomes None in + match o with + | Some (s,x,n,ex) -> + let ty = X.type_info x in + let r1 = x in + let r2 = P.alien_of (P.create [] n ty) in + [L.Eq(r1, r2), ex, s] + | None -> + [] + + let case_split env = + match case_split_polynomes env with + | [] -> case_split_monomes env + | choices -> choices + + let add env _ = env + + let extract_improved env = + SP.fold + (fun p acc -> + MP.add p (MP.find p env.polynomes) acc) + env.improved MP.empty + +end diff --git a/smt/fm.mli b/smt/fm.mli new file mode 100644 index 00000000..d438f617 --- /dev/null +++ b/smt/fm.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module type EXTENDED_Polynome = sig + include Polynome.T + val poly_of : r -> t + val alien_of : t -> r +end + +module Make + (X : Sig.X) + (P : EXTENDED_Polynome with type r = X.r) + : Sig.RELATION with type r = X.r diff --git a/smt/intervals.ml b/smt/intervals.ml new file mode 100644 index 00000000..62b3ecae --- /dev/null +++ b/smt/intervals.ml @@ -0,0 +1,703 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Num +open Format + +module Ex = Explanation + +type borne = + | Strict of (num * Ex.t) + | Large of (num * Ex.t) + | Pinfty | Minfty + +let compare_bornes b1 b2 = + match b1, b2 with + | Minfty, Minfty | Pinfty, Pinfty -> 0 + | Minfty, _ | _, Pinfty -> -1 + | Pinfty, _ | _, Minfty -> 1 + | Strict (v1, _), Strict (v2, _) | Large (v1, _), Large (v2, _) + | Strict (v1, _), Large (v2, _) | Large (v1, _), Strict (v2, _) -> + compare_num v1 v2 + +let compare_bu_bl b1 b2 = + match b1, b2 with + | (Minfty | Pinfty), _ | _,(Minfty | Pinfty) + | Strict _, Strict _ | Large _, Large _ -> + compare_bornes b1 b2 + | Strict (v1, _), Large (v2, _) | Large (v1, _), Strict (v2, _) -> + let c = compare_num v1 v2 in + if c = 0 then -1 else c + +let compare_bl_bu b1 b2 = + match b1, b2 with + | (Minfty | Pinfty), _ | _,(Minfty | Pinfty) + | Strict _, Strict _ | Large _, Large _ -> + compare_bornes b1 b2 + | Strict (v1, _), Large (v2, _) | Large (v1, _), Strict (v2, _) -> + let c = compare_num v1 v2 in + if c = 0 then 1 else c + +let compare_bl_bl b1 b2 = + match b1, b2 with + | (Minfty | Pinfty), _ | _,(Minfty | Pinfty) + | Strict _, Strict _ | Large _, Large _ -> + compare_bornes b1 b2 + | Strict (v1, _), Large (v2, _) -> + let c = compare_num v1 v2 in + if c = 0 then 1 else c + | Large (v1, _), Strict (v2, _) -> + let c = compare_num v1 v2 in + if c = 0 then -1 else c + +let compare_bu_bu b1 b2 = + match b1, b2 with + | (Minfty | Pinfty), _ | _,(Minfty | Pinfty) + | Strict _, Strict _ | Large _, Large _ -> + compare_bornes b1 b2 + | Strict (v1, _), Large (v2, _) -> + let c = compare_num v1 v2 in + if c = 0 then -1 else c + | Large (v1, _), Strict (v2, _) -> + let c = compare_num v1 v2 in + if c = 0 then 1 else c + +type t = { + ints : (borne * borne) list; + is_int : bool; + expl: Ex.t +} + +exception EmptyInterval of Ex.t +exception NotConsistent of Ex.t +exception Not_a_float + +let print_borne fmt = function + | Minfty -> fprintf fmt "-inf" + | Pinfty -> fprintf fmt "+inf" + | Strict (v, e) | Large (v, e) -> + fprintf fmt "%s" (string_of_num v) + +let print_interval fmt (b1,b2) = + let c1, c2 = match b1, b2 with + | Large _, Large _ -> '[', ']' + | Large _, _ -> '[', '[' + | _, Large _ -> ']', ']' + | _, _ -> ']', '[' + in + fprintf fmt "%c%a;%a%c" c1 print_borne b1 print_borne b2 c2 + +let print fmt {ints = ints; is_int = b; expl = e } = + List.iter (fun i -> fprintf fmt "%a" print_interval i) ints + + +let undefined ty = { + ints = [Minfty, Pinfty]; + is_int = ty = Ty.Tint; + expl = Ex.empty +} + +let point b ty e = { + ints = [Large (b, e), Large (b, e)]; + is_int = ty = Ty.Tint; + expl = Ex.empty +} + +let explain_borne = function + | Large (_, e) | Strict (_, e) -> e + | _ -> Ex.empty + +let add_expl_to_borne b e = + match b with + | Large (n, e') -> Large (n, Ex.union e e') + | Strict (n, e') -> Strict (n, Ex.union e e') + | Pinfty | Minfty -> b + +let borne_of k e n = if k then Large (n, e) else Strict (n, e) + +let is_point { ints = l; expl = e } = + match l with + | [Large (v1, e1) , Large (v2, e2)] when v1 =/ v2 -> + Some (v1, Ex.union e2 (Ex.union e1 e)) + | _ -> None + +let add_expl_zero i expl = + let res = List.map (fun x -> + match x with + | (Large ((Num.Int 0), e1) , Large ((Num.Int 0), e2)) -> + (Large ((Num.Int 0), Ex.union e1 expl), + Large ((Num.Int 0), Ex.union e2 expl)) + | _ -> x) i.ints in + { i with ints = res } + +let check_one_interval b1 b2 is_int = + match b1, b2 with + | Pinfty, _ | _, Minfty -> raise (EmptyInterval Ex.empty) + | (Strict (v1, e1) | Large (v1,e1)), + (Strict (v2, e2) | Large (v2, e2)) -> + let c = compare_num v1 v2 in + if c > 0 then raise + (EmptyInterval (Ex.union e2 e1)); + if c = 0 then begin + match b1, b2 with + | Large _, Large _ when not is_int || is_integer_num v1 -> + () + | _ -> raise (EmptyInterval (Ex.union e2 e1)) + end + | _ -> () + +let min_borne b1 b2 = + match b1, b2 with + | Minfty , _ | _ , Minfty -> Minfty + | b , Pinfty | Pinfty, b -> b + | (Strict (v1, _) | Large (v1, _)) , (Strict (v2, _) | Large (v2, _)) -> + let c = compare_num v1 v2 in + if c < 0 then b1 + else if c > 0 then b2 + else match b1, b2 with + | (Strict _ as b) , _ | _, (Strict _ as b) -> b + | _, _ -> b1 + +let max_borne b1 b2 = + match b1, b2 with + | Pinfty , _ | _ , Pinfty -> Pinfty + | b , Minfty | Minfty, b -> b + | (Strict (v1, _) | Large (v1, _)) , (Strict (v2, _) | Large (v2, _)) -> + let c = compare_num v1 v2 in + if c > 0 then b1 + else if c < 0 then b2 + else match b1, b2 with + | (Strict _ as b) , _ | _, (Strict _ as b) -> b + | _, _ -> b1 + +let pos_borne b1 = + compare_bornes b1 (borne_of true Ex.empty (Int 0)) >= 0 +let pos_borne_strict b1 = + compare_bornes b1 (borne_of true Ex.empty (Int 0)) > 0 +let neg_borne b1 = + compare_bornes b1 (borne_of true Ex.empty (Int 0)) <= 0 +let neg_borne_strict b1 = + compare_bornes b1 (borne_of true Ex.empty (Int 0)) < 0 +let zero_borne b1 = + compare_bornes b1 (borne_of true Ex.empty (Int 0)) = 0 + +exception Found of Sig.answer + +let doesnt_contain_0 {ints=l} = + try + let max = List.fold_left + (fun old_u (l, u) -> + if neg_borne l && pos_borne u then raise (Found Sig.No); + if neg_borne_strict old_u && pos_borne_strict l then + raise (Found + (Sig.Yes + (Ex.union + (explain_borne old_u) (explain_borne l)))); + u) Minfty l in + if neg_borne_strict max then Sig.Yes (explain_borne max) + else Sig.No + with Found ans -> ans + +let is_strict_smaller i1 i2 = + match i1, i2 with + | _, [] -> false + | [], _ -> true + | _ -> + try + List.iter2 (fun (l1, u1) (l2, u2) -> + if compare_bornes l1 l2 > 0 || compare_bornes u1 u2 < 0 + then raise Exit + ) i1 i2; + false + with + | Exit -> true + | Invalid_argument _ -> List.length i1 > List.length i2 + +let is_strict_smaller {ints=i1} {ints=i2} = + is_strict_smaller i1 i2 + + +let rec union_bornes l = + match l with + | [] | [_] -> l + | (l1, u1)::((l2, u2)::r as r2) -> + if compare_bornes u1 l2 < 0 then + (l1, u1)::(union_bornes r2) + else if compare_bornes u1 u2 > 0 then + union_bornes ((l1, u1)::r) + else + union_bornes ((l1, u2)::r) + +let union ({ints = l} as uints) = + let l = List.sort (fun (l1, _) (l2, _) -> compare_bornes l1 l2) l in + { uints with ints = union_bornes l } + +let add_borne b1 b2 = + match b1,b2 with + | Minfty, Pinfty | Pinfty, Minfty -> assert false + | Minfty, _ | _, Minfty -> Minfty + | Pinfty, _ | _, Pinfty -> Pinfty + | Large (v1, e1), Large (v2, e2) -> + Large (v1 +/ v2, Ex.union e1 e2) + | (Large (v1, e1) | Strict (v1, e1)), (Large (v2, e2) | Strict (v2, e2)) -> + Strict (v1 +/ v2, Ex.union e1 e2) + +let add_interval l (b1,b2) = + List.fold_right + (fun (b1', b2') l -> + let l1 = ((add_borne b1 b1'),(add_borne b2 b2'))::l in + union_bornes (l1) + ) l [] + +let add {ints = l1; is_int = is_int; expl = e1} {ints = l2; expl = e2}= + let l = + List.fold_left + (fun l bs -> let i = add_interval l1 bs in i@l) [] l2 + in + union { ints = l ; is_int = is_int; expl = Ex.union e1 e2 } + +let minus_borne = function + | Minfty -> Pinfty + | Pinfty -> Minfty + | Large (v, e) -> Large (minus_num v, e) + | Strict (v, e) -> Strict (minus_num v, e) + +let scale_borne n b = + assert (n >=/ Int 0); + if n =/ Int 0 then + match b with + | Pinfty | Minfty -> Large (Int 0, Ex.empty) + | Large (_, e) | Strict (_, e) -> Large (Int 0, e) + else match b with + | Pinfty | Minfty -> b + | Large (v, e) -> Large (n */ v, e) + | Strict (v, e) -> Strict (n */ v, e) + +let scale_interval n (b1,b2) = + if n assert false + | Minfty, b | b, Minfty -> + if compare_bornes b (borne_of true Ex.empty (Int 0)) = 0 + then b + else if pos_borne b then Minfty + else Pinfty + | Pinfty, b | b, Pinfty -> + if compare_bornes b (borne_of true Ex.empty (Int 0)) = 0 + then b + else if pos_borne b then Pinfty + else Minfty + | Strict (v1, e1), Strict (v2, e2) | Strict (v1, e1), Large (v2, e2) + | Large (v1, e1), Strict (v2, e2) -> + Strict (v1 */ v2, Ex.union e1 e2) + | Large (v1, e1), Large (v2, e2) -> + Large (v1 */ v2, Ex.union e1 e2) + +let mult_borne_inf b1 b2 = + match b1,b2 with + | Minfty, Pinfty | Pinfty, Minfty -> Minfty + | _, _ -> mult_borne b1 b2 + +let mult_borne_sup b1 b2 = + match b1,b2 with + | Minfty, Pinfty | Pinfty, Minfty -> Pinfty + | _, _ -> mult_borne b1 b2 + +type interval_class = + | P of Ex.t + | M of Ex.t + | N of Ex.t + | Z + +let class_of (l,u) = + if zero_borne l && zero_borne u then Z + else if pos_borne l && pos_borne u then P (explain_borne l) + else if neg_borne l && neg_borne u then N (explain_borne u) + else M (Ex.union (explain_borne l) (explain_borne u)) + +let mult_bornes (a,b) (c,d) = + (* see util/intervals_mult.png *) + match class_of (a,b), class_of (c,d) with + | P e1, P e2 -> + mult_borne_inf a c, mult_borne_sup b d, Ex.union e1 e2 + | P e1, M e2 -> + mult_borne_inf b c, mult_borne_sup b d, Ex.union e1 e2 + | P e1, N e2 -> + mult_borne_inf b c, mult_borne_sup a d, Ex.union e1 e2 + | M e1, P e2 -> + mult_borne_inf a d, mult_borne_sup b d, Ex.union e1 e2 + | M e1, M e2 -> + min_borne (mult_borne_inf a d) (mult_borne_inf b c), + max_borne (mult_borne_sup a c) (mult_borne_sup b d), + Ex.union e1 e2 + | M e1, N e2 -> + mult_borne_inf b c, mult_borne_sup a c, Ex.union e1 e2 + | N e1, P e2 -> + mult_borne_inf a d, mult_borne_sup b c, Ex.union e1 e2 + | N e1, M e2 -> + mult_borne_inf a d, mult_borne_sup a c, Ex.union e1 e2 + | N e1, N e2 -> + mult_borne_inf b d, mult_borne_sup a c, Ex.union e1 e2 + | Z, (P _ | M _ | N _ | Z) -> (a, b, Ex.empty) + | (P _ | M _ | N _ ), Z -> (c, d, Ex.empty) + +let rec power_borne_inf p b = + match p with + | 1 -> b + | p -> mult_borne_inf b (power_borne_inf (p-1) b) + +let rec power_borne_sup p b = + match p with + | 1 -> b + | p -> mult_borne_sup b (power_borne_sup (p-1) b) + +let max_merge b1 b2 = + let ex = Ex.union (explain_borne b1) (explain_borne b2) in + let max = max_borne b1 b2 in + match max with + | Minfty | Pinfty -> max + | Large (v, e) -> Large (v, ex) + | Strict (v, e) -> Strict (v, ex) + +let power_bornes p (b1,b2) = + if neg_borne b1 && pos_borne b2 then + match p with + | 0 -> assert false + | p when p mod 2 = 0 -> + (* max_merge to have explanations !!! *) + let m = max_merge (power_borne_sup p b1) (power_borne_sup p b2) in + (Large (Int 0, Ex.empty), m) + | _ -> (power_borne_inf p b1, power_borne_sup p b2) + else if pos_borne b1 && pos_borne b2 then + (power_borne_inf p b1, power_borne_sup p b2) + else if neg_borne b1 && neg_borne b2 then + match p with + | 0 -> assert false + | p when p mod 2 = 0 -> (power_borne_inf p b2, power_borne_sup p b1) + | _ -> (power_borne_inf p b1, power_borne_sup p b2) + else assert false + +let int_of_borne_inf b = + match b with + | Minfty | Pinfty -> b + | Large (v, e) -> Large (ceiling_num v, e) + | Strict (v, e) -> + let v' = ceiling_num v in + if v' >/ v then Large (v', e) else Large (v +/ (Int 1), e) + +let int_of_borne_sup b = + match b with + | Minfty | Pinfty -> b + | Large (v, e) -> Large (floor_num v, e) + | Strict (v, e) -> + let v' = floor_num v in + if v' b + | Large (v, e) -> Large (floor_num v, e) + | Strict (v, e) -> + let v' = floor_num v in + if v' >/ v then Large (v', e) else Large (v +/ (Int 1), e) + +let int_div_of_borne_sup b = + match b with + | Minfty | Pinfty -> b + | Large (v, e) -> Large (floor_num v, e) + | Strict (v, e) -> + let v' = floor_num v in + if v' + let (lo1,up1), (lo2,up2) = + if is_int then (int_bornes lo1 up1), (int_bornes lo2 up2) + else (lo1,up1), (lo2,up2) in + let cll = compare_bl_bl lo1 lo2 in + let cuu = compare_bu_bu up1 up2 in + let clu = compare_bl_bu lo1 up2 in + let cul = compare_bu_bl up1 lo2 in + if cul < 0 then + let nexpl = Ex.union (explain_borne up1) (explain_borne lo2) in + match r1 with + | [] -> step (r1, l2) acc (Ex.union nexpl expl) + | (lor1,upr1)::rr1 -> + let lor1 = add_expl_to_borne lor1 nexpl in + let r1 = (lor1,upr1)::rr1 in + step (r1, l2) acc expl + else if clu > 0 then + let nexpl = Ex.union (explain_borne up2) (explain_borne lo1) in + match r2 with + | [] -> step (l1, r2) acc (Ex.union nexpl expl) + | (lor2,upr2)::rr2 -> + let lor2 = add_expl_to_borne lor2 nexpl in + let r2 = (lor2,upr2)::rr2 in + step (l1, r2) acc expl + else if cll = 0 && cuu = 0 then + step (r1, r2) ((lo1,up1)::acc) expl + else if cll <= 0 && cuu >= 0 then + step (l1, r2) ((lo2,up2)::acc) expl + else if cll >= 0 && cuu <= 0 then + step (r1, l2) ((lo1,up1)::acc) expl + else if cll <= 0 && cuu <= 0 && cul >= 0 then + step (r1, l2) ((lo2,up1)::acc) expl + else if cll >= 0 && cuu >= 0 && clu <= 0 then + step (l1, r2) ((lo1,up2)::acc) expl + else assert false + | [], _ | _, [] -> List.rev acc, expl + in + let l, expl = step (l1,l2) [] (Ex.union e1 e2) in + if l = [] then raise (NotConsistent expl) + else { uints1 with ints = l; expl = expl } + + +let new_borne_sup expl b ~is_le uints = + intersect + { ints = [Minfty, (borne_of is_le expl b)]; + is_int = uints.is_int; + expl = Ex.empty } uints + +let new_borne_inf expl b ~is_le uints = + intersect + { ints = [(borne_of is_le expl b), Pinfty]; + is_int = uints.is_int; + expl = Ex.empty } uints + +let complement ({ints=l; expl=e} as uints) = + let rec step l prev acc = + match l with + | (b1,b2)::r -> + let bu = match b1 with + | Strict v -> Large v + | Large v -> Strict v + | _ -> b1 in + let bl = match b2 with + | Strict v -> Large v + | Large v -> Strict v + | _ -> b2 in + if bu = Minfty then step r bl acc + else step r bl ((prev, bu)::acc) + | [] -> + if prev = Pinfty then List.rev acc + else List.rev ((prev, Pinfty)::acc) + in + { uints with ints = step l Minfty [] } + + +let exclude uints1 uints2 = + intersect (complement uints1) uints2 + +let mult u1 u2 = + let resl, expl = + List.fold_left + (fun (l', expl) b1 -> + List.fold_left + (fun (l, ex) b2 -> + let bl, bu, ex' = mult_bornes b1 b2 in + (bl, bu)::l, Ex.union ex ex') (l', expl) u2.ints) + ([], Ex.empty) u1.ints + in + union { ints=resl; is_int = u1.is_int; + expl = Ex.union expl + (Ex.union u1.expl u2.expl) } + +let power n u = + let l = List.map (power_bornes n) u.ints in + union { u with ints = l } + + +let num_of_float x = + if x = infinity or x = neg_infinity then raise Not_a_float; + let (f, n) = frexp x in + let z = + Big_int.big_int_of_string + (Int64.to_string (Int64.of_float (f *. 2. ** 52.))) in + (* + Si on a ocaml >= 3.11 on peut mettre (mieux) : + let z = + Big_int.big_int_of_int64 + (Int64.of_float (f *. 2. ** 52.)) in + *) + let factor = (Int 2) **/ (Int (n - 52)) in + (Big_int z) */ factor + +let root_num a n = + if a =/ (Int 0) then s else a // (s **/ ((Int n) -/ (Int 1))) + +let root_exces_num a n = + let s = root_num a n in + let d = a -/ (s **/ (Int n)) in + if d <=/ (Int 0) then s else a // (s **/ ((Int n) -/ (Int 1))) + +let root_default_borne is_int x n = + match x with + | Pinfty -> Pinfty + | Minfty -> Minfty + | Large (v, e) | Strict (v, e) -> + let s = if v >=/ (Int 0) then root_default_num v n + else (minus_num (root_exces_num (minus_num v) n)) in + if is_int then + let cs = ceiling_num s in + let cs2 = cs **/ (Int n) in + if v <=/ cs2 then Large (cs, e) + else Large (cs +/ (Int 1), e) + else Large (s, e) + +let root_exces_borne is_int x n = + match x with + | Pinfty -> Pinfty + | Minfty -> Minfty + | Large (v, e) | Strict (v, e) -> + let s = if v >=/ (Int 0) then root_exces_num v n + else (minus_num (root_default_num (minus_num v) n)) in + if is_int then + let cs = floor_num s in + let cs2 = cs **/ (Int n) in + if v >=/ cs2 then Large (cs, e) + else Large (cs -/ (Int 1), e) + else Large (s, e) + +let sqrt_interval is_int (b1,b2) = + let l1, u1 = (minus_borne (root_exces_borne is_int b2 2), + minus_borne (root_default_borne is_int b1 2)) in + let l2, u2 = (root_default_borne is_int b1 2, + root_exces_borne is_int b2 2) in + if compare_bornes l1 u1 > 0 then + if compare_bornes l2 u2 > 0 then [] + else [l2,u2] + else if compare_bornes l2 u2 > 0 then [l1, u1] + else union_bornes [(l1,u1); (l2, u2)] + +let root_interval is_int (b1,b2) n = + let u,l = (root_default_borne is_int b1 n, root_exces_borne is_int b2 n) in + if compare_bornes u l > 0 then [] else [u,l] + +let sqrt {ints = l; is_int = is_int; expl = e } = + let l = + List.fold_left + (fun l' bs -> + (sqrt_interval is_int bs)@l' + ) [] l in + union { ints = l; is_int = is_int; expl = e } + +let rec root n ({ints = l; is_int = is_int; expl = e} as u) = + if n mod 2 = 0 then root (n/2) (sqrt u) + else + let l = + List.fold_left + (fun l' bs -> + (root_interval is_int bs n)@l' + ) [] l in + union { ints = l; is_int = is_int; expl = e } + +let finite_size {ints = l; is_int = is_int} = + if (not is_int) then None + else + try + let n = + List.fold_left + (fun n (b1,b2) -> + match b1, b2 with + | Minfty, _ | _, Pinfty -> raise Exit + | Large (v1, _) , Large (v2, _) -> n +/ (v2 -/ v1 +/ (Int 1)) + | _, _ -> assert false + ) (Int 0) l in + Some n + with Exit -> None + +let borne_inf = function + | {ints = (Large (v, ex), _)::_} -> v, ex + | _ -> invalid_arg "Intervals.borne_inf : No finite lower bound" + + + +let inv_borne_inf b is_int ~other = + match b with + | Pinfty -> assert false + | Minfty -> + if is_int then Large (Int 0, explain_borne other) + else Strict (Int 0, explain_borne other) + | Strict (Int 0, e) | Large (Int 0, e) -> Pinfty + | Strict (v, e) -> Strict (Int 1 // v, e) + | Large (v, e) -> Large (Int 1 // v, e) + +let inv_borne_sup b is_int ~other = + match b with + | Minfty -> assert false + | Pinfty -> + if is_int then Large (Int 0, explain_borne other) + else Strict (Int 0, explain_borne other) + | Strict (Int 0, e) | Large (Int 0, e) -> Minfty + | Strict (v, e) -> Strict (Int 1 // v, e) + | Large (v, e) -> Large (Int 1 // v, e) + +let inv_bornes (l, u) is_int = + inv_borne_sup u is_int ~other:l, inv_borne_inf l is_int ~other:u + + +let inv ({ints=l; is_int=is_int} as u) = + try + let l' = List.fold_left + (fun acc (l,u) -> + if (pos_borne_strict l && pos_borne_strict u) + || (neg_borne_strict l && neg_borne_strict u) then + (inv_bornes (l, u) is_int) :: acc + else raise Exit + ) [] l in + union { u with ints=l' } + with Exit -> { u with ints = [Minfty, Pinfty] } + +let div i1 i2 = + let inv_i2 = inv i2 in + if inv_i2.ints = [Minfty, Pinfty] then inv_i2 + else + let i1 = match doesnt_contain_0 i2 with + | Sig.Yes ex -> add_expl_zero i1 ex + | Sig.No -> i1 + in + let ({ints=l; is_int=is_int} as i) = mult i1 inv_i2 in + let l = + if is_int then + List.map (fun (l,u) -> int_div_bornes l u) l + else l in + { i with ints = l } diff --git a/smt/intervals.mli b/smt/intervals.mli new file mode 100644 index 00000000..bf5e1e68 --- /dev/null +++ b/smt/intervals.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Num + +type t + +exception NotConsistent of Explanation.t +exception Not_a_float + +val undefined : Ty.t -> t + +val point : num -> Ty.t -> Explanation.t -> t + +val doesnt_contain_0 : t -> Sig.answer + +val is_strict_smaller : t -> t -> bool + +val new_borne_sup : Explanation.t -> num -> is_le : bool -> t -> t + +val new_borne_inf : Explanation.t -> num -> is_le : bool -> t -> t + +val is_point : t -> (num * Explanation.t) option + +val intersect : t -> t -> t + +val exclude : t -> t -> t + +val mult : t -> t -> t + +val power : int -> t -> t + +val sqrt : t -> t + +val root : int -> t -> t + +val add : t -> t -> t + +val scale : num -> t -> t + +val print : Format.formatter -> t -> unit + +val finite_size : t -> num option + +val borne_inf : t -> num * Explanation.t + +val div : t -> t -> t diff --git a/smt/literal.ml b/smt/literal.ml new file mode 100644 index 00000000..9c9285b7 --- /dev/null +++ b/smt/literal.ml @@ -0,0 +1,210 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Hashcons + +type 'a view = + | Eq of 'a * 'a + | Distinct of bool * 'a list + | Builtin of bool * Hstring.t * 'a list + +module type OrderedType = sig + type t + val compare : t -> t -> int + val hash : t -> int + val print : Format.formatter -> t -> unit +end + +module type S = sig + type elt + type t + + val make : elt view -> t + val view : t -> elt view + + val neg : t -> t + + val add_label : Hstring.t -> t -> unit + val label : t -> Hstring.t + + val print : Format.formatter -> t -> unit + + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + + module Map : Map.S with type key = t + module Set : Set.S with type elt = t + +end + +module Make (X : OrderedType) : S with type elt = X.t = struct + + type elt = X.t + type t = (X.t view) hash_consed + + module V = struct + type t = X.t view + + let equal a1 a2 = + match a1, a2 with + | Eq(t1, t2), Eq(u1, u2) -> + (X.compare t1 u1 = 0 && X.compare t2 u2 = 0) || + (X.compare t1 u2 = 0 && X.compare t2 u1 = 0) + | Distinct (b1,lt1), Distinct (b2,lt2) -> + (try + b1 = b2 && + List.for_all2 (fun x y -> X.compare x y = 0) lt1 lt2 + with Invalid_argument _ -> false) + | Builtin(b1, n1, l1), Builtin(b2, n2, l2) -> + (try + b1 = b2 && Hstring.equal n1 n2 + && + List.for_all2 (fun x y -> X.compare x y = 0) l1 l2 + with Invalid_argument _ -> false) + | _ -> false + + let hash a = match a with + | Eq(t1, t2) -> abs (19 * (X.hash t1 + X.hash t2)) + | Distinct (b,lt) -> + let x = if b then 7 else 23 in + abs (17 * List.fold_left (fun acc t -> (X.hash t) + acc ) x lt) + | Builtin(b, n, l) -> + let x = if b then 7 else 23 in + abs + (List.fold_left + (fun acc t-> acc*13 + X.hash t) (Hstring.hash n+x) l) + end + + module H = Make_consed(V) + + let compare a1 a2 = Pervasives.compare a1.tag a2.tag + let equal a1 a2 = a1 == a2 + let hash a1 = a1.tag + + module T = struct + type t' = t + type t = t' + let compare=compare + let equal = equal + let hash = hash + end + + let make t = H.hashcons t + let view a = a.node + + let neg a = match view a with + | Eq(x, y) -> make (Distinct (false,[x; y])) + | Distinct (false, [x; y]) -> make (Eq (x, y)) + | Distinct (true, [x; y]) -> make (Distinct (false,[x; y])) + | Distinct (false, l) -> make (Distinct (true,l)) + | Distinct _ -> assert false + | Builtin(b, n, l) -> make (Builtin (not b, n, l)) + + module Labels = Hashtbl.Make(T) + + let labels = Labels.create 100007 + + let add_label lbl t = Labels.replace labels t lbl + + let label t = try Labels.find labels t with Not_found -> Hstring.empty + + let print_list fmt = function + | [] -> () + | z :: l -> + Format.fprintf fmt "%a" X.print z; + List.iter (Format.fprintf fmt ", %a" X.print) l + + let ale = Hstring.make "<=" + let alt = Hstring.make "<" + + let print fmt a = + let lbl = Hstring.view (label a) in + let lbl = if lbl = "" then lbl else lbl^":" in + match view a with + | Eq (z1, z2) -> + if equal z1 z2 then Format.fprintf fmt "True" + else Format.fprintf fmt "%s%a=%a" lbl X.print z1 X.print z2 + | Distinct (b,(z::l)) -> + let b = if b then "~" else "" in + Format.fprintf fmt "%s%s%a" lbl b X.print z; + List.iter (fun x -> Format.fprintf fmt "<>%a" X.print x) l + + | Builtin (true, n, [v1;v2]) when Hstring.equal n ale -> + Format.fprintf fmt "%s %a <= %a" lbl X.print v1 X.print v2 + + | Builtin (true, n, [v1;v2]) when Hstring.equal n alt -> + Format.fprintf fmt "%s %a < %a" lbl X.print v1 X.print v2 + + | Builtin (false, n, [v1;v2]) when Hstring.equal n ale -> + Format.fprintf fmt "%s %a > %a" lbl X.print v1 X.print v2 + + | Builtin (false, n, [v1;v2]) when Hstring.equal n alt -> + Format.fprintf fmt "%s %a >= %a" lbl X.print v1 X.print v2 + + | Builtin (b, n, l) -> + let b = if b then "" else "~" in + Format.fprintf fmt "%s%s%s(%a)" lbl b (Hstring.view n) print_list l + | _ -> assert false + + module Set = Set.Make(T) + module Map = Map.Make(T) + +end + +module type S_Term = sig + + include S with type elt = Term.t + + val mk_pred : Term.t -> t + + val vrai : t + val faux : t + +(* val terms_of : t -> Term.Set.t + val vars_of : t -> Symbols.Set.t +*) +(* module SetEq : Set.S with type elt = t * Term.t * Term.t*) +end + +module LT : S_Term = struct + + module L = Make(Term) + include L + + let mk_pred t = make (Eq (t, Term.vrai) ) + + let vrai = mk_pred Term.vrai + let faux = mk_pred Term.faux + + let neg a = match view a with + | Eq(t1, t2) when Term.equal t2 Term.faux -> + make (Eq (t1, Term.vrai)) + | Eq(t1, t2) when Term.equal t2 Term.vrai -> + make (Eq (t1, Term.faux)) + | _ -> L.neg a + +(* let terms_of a = + let l = match view a with + | Eq (t1, t2) -> [t1; t2] + | Distinct (_, l) | Builtin (_, _, l) -> l + in + List.fold_left Term.subterms Term.Set.empty l +*) + + module SS = Symbols.Set +(* let vars_of a = + Term.Set.fold (fun t -> SS.union (Term.vars_of t)) (terms_of a) SS.empty +*) +end + diff --git a/smt/literal.mli b/smt/literal.mli new file mode 100644 index 00000000..b4915092 --- /dev/null +++ b/smt/literal.mli @@ -0,0 +1,63 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module type OrderedType = sig + type t + val compare : t -> t -> int + val hash : t -> int + val print : Format.formatter -> t -> unit +end + +type 'a view = + | Eq of 'a * 'a + | Distinct of bool * 'a list + | Builtin of bool * Hstring.t * 'a list + +module type S = sig + type elt + type t + + val make : elt view -> t + val view : t -> elt view + + val neg : t -> t + + val add_label : Hstring.t -> t -> unit + val label : t -> Hstring.t + + val print : Format.formatter -> t -> unit + + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int + + module Map : Map.S with type key = t + module Set : Set.S with type elt = t + +end + +module Make ( X : OrderedType ) : S with type elt = X.t + +module type S_Term = sig + + include S with type elt = Term.t + + val mk_pred : Term.t -> t + val vrai : t + val faux : t + +end + +module LT : S_Term + + diff --git a/smt/polynome.ml b/smt/polynome.ml new file mode 100644 index 00000000..d49fd56b --- /dev/null +++ b/smt/polynome.ml @@ -0,0 +1,257 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Alain Mebsout *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format +open Num + +exception Not_a_num +exception Maybe_zero + +module type S = sig + type r + val compare : r -> r -> int + val term_embed : Term.t -> r + val mult : r -> r -> r + val print : Format.formatter -> r -> unit +end + +module type T = sig + + type r + type t + + val compare : t -> t -> int + val hash : t -> int + val create : (num * r) list -> num -> Ty.t-> t + val add : t -> t -> t + val sub : t -> t -> t + val mult : t -> t -> t + val mult_const : num -> t -> t + val div : t -> t -> t * bool + val modulo : t -> t -> t + + val is_empty : t -> bool + val find : r -> t -> num + val choose : t -> num * r + val subst : r -> t -> t -> t + val remove : r -> t -> t + val to_list : t -> (num * r) list * num + + val print : Format.formatter -> t -> unit + val type_info : t -> Ty.t + val is_monomial : t -> (num * r * num) option + + val ppmc_denominators : t -> num + val pgcd_numerators : t -> num + val normal_form : t -> t * num * num + val normal_form_pos : t -> t * num * num +end + +module Make (X : S) = struct + + type r = X.r + + module M : Map.S with type key = r = + Map.Make(struct type t = r let compare x y = X.compare y x end) + + type t = { m : num M.t; c : num; ty : Ty.t } + + let compare p1 p2 = + let c = Ty.compare p1.ty p2.ty in + if c <> 0 then c + else + let c = compare_num p1.c p2.c in + if c = 0 then M.compare compare_num p1.m p2.m else c + + let hash p = + abs (Hashtbl.hash p.m + 19*Hashtbl.hash p.c + 17 * Ty.hash p.ty) + + let pprint fmt p = + M.iter + (fun x n -> + let s, n, op = match n with + | Int 1 -> "+", "", "" + | Int -1 -> "-", "", "" + | n -> + if n >/ Int 0 then "+", string_of_num n, "*" + else "-", string_of_num (minus_num n), "*" + in + fprintf fmt "%s%s%s%a" s n op X.print x + )p.m; + let s, n = if p.c >=/ Int 0 then "+", string_of_num p.c + else "-", string_of_num (minus_num p.c) in + fprintf fmt "%s%s" s n + + + let print fmt p = + M.iter + (fun t n -> fprintf fmt "%s*%a " (string_of_num n) X.print t) p.m; + fprintf fmt "%s" (string_of_num p.c); + fprintf fmt " [%a]" Ty.print p.ty + + let is_num p = M.is_empty p.m + + let find x m = try M.find x m with Not_found -> Int 0 + + let create l c ty = + let m = + List.fold_left + (fun m (n, x) -> + let n' = n +/ (find x m) in + if n' =/ (Int 0) then M.remove x m else M.add x n' m) M.empty l + in + { m = m; c = c; ty = ty } + + let add p1 p2 = + let m = + M.fold + (fun x a m -> + let a' = (find x m) +/ a in + if a' =/ (Int 0) then M.remove x m else M.add x a' m) + p2.m p1.m + in + { m = m; c = p1.c +/ p2.c; ty = p1.ty } + + let mult_const n p = + if n =/ (Int 0) then { m = M.empty; c = Int 0; ty = p.ty } + else { p with m = M.map (mult_num n) p.m; c = n */ p.c } + + let mult_monome a x p = + let ax = { m = M.add x a M.empty; c = (Int 0); ty = p.ty} in + let acx = mult_const p.c ax in + let m = + M.fold + (fun xi ai m -> M.add (X.mult x xi) (a */ ai) m) p.m acx.m + in + { acx with m = m} + + let mult p1 p2 = + let p = mult_const p1.c p2 in + M.fold (fun x a p -> add (mult_monome a x p2) p) p1.m p + + let sub p1 p2 = + add p1 (mult (create [] (Int (-1)) p1.ty) p2) + + let div p1 p2 = + if M.is_empty p2.m then + if p2.c =/ Int 0 then raise Division_by_zero + else + let p = mult_const ((Int 1) // p2.c) p1 in + match M.is_empty p.m, p.ty with + | true, Ty.Tint -> {p with c = floor_num p.c}, false + | true, Ty.Treal -> p, false + | false, Ty.Tint -> p, true + | false, Ty.Treal -> p, false + | _ -> assert false + else raise Maybe_zero + + + let modulo p1 p2 = + if M.is_empty p2.m then + if p2.c =/ Int 0 then raise Division_by_zero + else + if M.is_empty p1.m then { p1 with c = mod_num p1.c p2.c } + else raise Not_a_num + else raise Maybe_zero + + let find x p = M.find x p.m + + let is_empty p = M.is_empty p.m + + let choose p = + let tn= ref None in + (*version I : prend le premier element de la table*) + (try M.iter + (fun x a -> tn := Some (a, x); raise Exit) p.m with Exit -> ()); + (*version II : prend le dernier element de la table i.e. le plus grand + M.iter (fun x a -> tn := Some (a, x)) p.m;*) + match !tn with Some p -> p | _ -> raise Not_found + + let subst x p1 p2 = + try + let a = M.find x p2.m in + add (mult_const a p1) { p2 with m = M.remove x p2.m} + with Not_found -> p2 + + let remove x p = { p with m = M.remove x p.m } + + let to_list p = + let l = M.fold (fun x a aliens -> (a, x)::aliens ) p.m [] in + List.rev l, p.c + + let type_info p = p.ty + + let is_monomial p = + try + M.fold + (fun x a r -> + match r with + | None -> Some (a, x, p.c) + | _ -> raise Exit) + p.m None + with Exit -> None + + let denominator = function + | Num.Int _ | Num.Big_int _ -> Big_int.unit_big_int + | Num.Ratio rat -> Ratio.denominator_ratio rat + + let numerator = function + | Num.Int i -> Big_int.big_int_of_int i + | Num.Big_int b -> b + | Num.Ratio rat -> Ratio.numerator_ratio rat + + let pgcd_bi a b = Big_int.gcd_big_int a b + + let ppmc_bi a b = Big_int.div_big_int (Big_int.mult_big_int a b) (pgcd_bi a b) + + let abs_big_int_to_num b = + let b = + try Int (Big_int.int_of_big_int b) + with Failure "int_of_big_int" -> Big_int b + in + abs_num b + + let ppmc_denominators {m=m} = + let res = + M.fold + (fun k c acc -> ppmc_bi (denominator c) acc) + m Big_int.unit_big_int in + abs_num (num_of_big_int res) + + let pgcd_numerators {m=m} = + let res = + M.fold + (fun k c acc -> pgcd_bi (numerator c) acc) + m Big_int.zero_big_int in + abs_num (num_of_big_int res) + + let normal_form ({ m = m; c = c } as p) = + if M.is_empty m then + { p with c = Int 0 }, p.c, (Int 1) + else + let ppcm = ppmc_denominators p in + let pgcd = pgcd_numerators p in + let p = mult_const (ppcm // pgcd) p in + { p with c = Int 0 }, p.c, (pgcd // ppcm) + + let normal_form_pos p = + let p, c, d = normal_form p in + try + let a,x = choose p in + if a >/ (Int 0) then p, c, d + else mult_const (Int (-1)) p, minus_num c, minus_num d + with Not_found -> p, c, d + +end + diff --git a/smt/polynome.mli b/smt/polynome.mli new file mode 100644 index 00000000..9e7dc2c0 --- /dev/null +++ b/smt/polynome.mli @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Alain Mebsout *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Num + +exception Not_a_num +exception Maybe_zero + +module type S = sig + type r + val compare : r -> r-> int + val term_embed : Term.t -> r + val mult : r -> r -> r + val print : Format.formatter -> r -> unit +end + +module type T = sig + + type r + type t + + val compare : t -> t -> int + val hash : t -> int + + val create : (num * r) list -> num -> Ty.t-> t + val add : t -> t -> t + val sub : t -> t -> t + val mult : t -> t -> t + val mult_const : num -> t -> t + val div : t -> t -> t * bool + val modulo : t -> t -> t + + val is_empty : t -> bool + val find : r -> t -> num + val choose : t -> num * r + val subst : r -> t -> t -> t + val remove : r -> t -> t + val to_list : t -> (num * r) list * num + + val print : Format.formatter -> t -> unit + val type_info : t -> Ty.t + val is_monomial : t -> (num * r * num) option + + (* PPMC des denominateurs des coefficients excepte la constante *) + val ppmc_denominators : t -> num + (* PGCD des numerateurs des coefficients excepte la constante *) + val pgcd_numerators : t -> num + (* retourne un polynome sans constante et sa constante + et la constante multiplicative: + normal_form p = (p',c,d) <=> p = (p' + c) * d *) + val normal_form : t -> t * num * num + (* comme normal_form mais le signe est aussi normalise *) + val normal_form_pos : t -> t * num * num +end + +module Make (X : S) : T with type r = X.r + diff --git a/smt/sig.mli b/smt/sig.mli new file mode 100644 index 00000000..667e756f --- /dev/null +++ b/smt/sig.mli @@ -0,0 +1,146 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type answer = Yes of Explanation.t | No + +type 'a literal = LSem of 'a Literal.view | LTerm of Literal.LT.t + +type 'a input = + 'a Literal.view * Literal.LT.t option * Explanation.t + +type 'a result = { + assume : ('a literal * Explanation.t) list; + remove: ('a literal * Explanation.t) list; +} + +module type RELATION = sig + type t + type r + + val empty : unit -> t + + val assume : t -> (r input) list -> t * r result + + val query : t -> r input -> answer + + val case_split : t -> (r Literal.view * Explanation.t * Num.num) list + (** case_split env returns a list of equalities *) + + val add : t -> r -> t + (** add a representant to take into account *) + +end + +module type THEORY = sig + + (**Type of terms of the theory*) + type t + + (**Type of representants of terms of the theory*) + type r + + (** Name of the theory*) + val name : string + + (** return true if the symbol is owned by the theory*) + val is_mine_symb : Symbols.t -> bool + + (** return true when the argument is an unsolvable function of the theory *) + val unsolvable : t -> bool + + (** Give a representant of a term of the theory*) + val make : Term.t -> r * Literal.LT.t list + + val term_extract : r -> Term.t option + + val type_info : t -> Ty.t + + val embed : r -> t + + (** Give the leaves of a term of the theory *) + val leaves : t -> r list + + val subst : r -> r -> t -> r + + val compare : t -> t -> int + + val hash : t -> int + (** solve r1 r2, solve the equality r1=r2 and return the substitution *) + + val solve : r -> r -> (r * r) list + + val print : Format.formatter -> t -> unit + + val fully_interpreted : Symbols.t -> bool + + module Rel : RELATION with type r = r +end + +module type COMBINATOR = sig + type r + type th + + val extract : r -> th + val make : Term.t -> r * Literal.LT.t list + val type_info : r -> Ty.t + val compare : r -> r -> int + val leaves : r -> r list + val subst : r -> r -> r -> r + val solve : r -> r -> (r * r) list + val empty_embedding : Term.t -> r + val normal_form : Literal.LT.t -> Literal.LT.t + val print : Format.formatter -> r -> unit + module Rel : RELATION with type r = r + +end + +module type X = sig + type r + + val make : Term.t -> r * Literal.LT.t list + + val type_info : r -> Ty.t + + val compare : r -> r -> int + + val equal : r -> r -> bool + + val hash : r -> int + + val leaves : r -> r list + + val subst : r -> r -> r -> r + + val solve : r -> r -> (r * r) list + + val term_embed : Term.t -> r + + val term_extract : r -> Term.t option + + val unsolvable : r -> bool + + val fully_interpreted : Symbols.t -> bool + + val print : Format.formatter -> r -> unit + + module Rel : RELATION with type r = r + +end + +module type C = sig + type t + type r + val extract : r -> t option + val embed : t -> r +end + diff --git a/smt/smt.ml b/smt/smt.ml new file mode 100644 index 00000000..4476257c --- /dev/null +++ b/smt/smt.ml @@ -0,0 +1,733 @@ +(**************************************************************************) +(* *) +(* Alt-Ergo Zero *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format + +type error = + | DuplicateTypeName of Hstring.t + | DuplicateSymb of Hstring.t + | UnknownType of Hstring.t + | UnknownSymb of Hstring.t + +exception Error of error + +module AETerm = Term +module H = Hstring.H +module HSet = Hstring.HSet + +let decl_types = H.create 17 +let decl_symbs = H.create 17 + +let htrue = Hstring.make "True" +let hfalse = Hstring.make "False" + +module Type = struct + + type t = Hstring.t + + let equal = Hstring.equal + + let type_int = + let tint = Hstring.make "int" in + H.add decl_types tint Ty.Tint; + tint + + let type_real = + let treal = Hstring.make "real" in + H.add decl_types treal Ty.Treal; + treal + + let type_bool = + let tbool = Hstring.make "bool" in + H.add decl_types tbool Ty.Tbool; + tbool + + let type_proc = + let tproc = Hstring.make "proc" in + H.add decl_types tproc Ty.Tint; + tproc + + let declare_constructor ty c = + if H.mem decl_symbs c then raise (Error (DuplicateSymb c)); + H.add decl_symbs c + (Symbols.name ~kind:Symbols.Constructor c, [], ty) + + let declare t constrs = + if H.mem decl_types t then raise (Error (DuplicateTypeName t)); + match constrs with + | [] -> + H.add decl_types t (Ty.Tabstract t) + | _ -> + let ty = Ty.Tsum (t, constrs) in + H.add decl_types t ty; + List.iter (fun c -> declare_constructor t c) constrs + + let all_constructors () = + H.fold (fun _ c acc -> match c with + | Symbols.Name (h, Symbols.Constructor), _, _ -> h :: acc + | _ -> acc + ) decl_symbs [htrue; hfalse] + + let constructors ty = + if Hstring.equal ty type_bool then [htrue; hfalse] + else match H.find decl_types ty with + | Ty.Tsum (_ , cstrs) -> cstrs + | _ -> raise Not_found + +end + +module Symbol = struct + + type t = Hstring.t + + let declare f args ret = + if H.mem decl_symbs f then raise (Error (DuplicateTypeName f)); + List.iter + (fun t -> + if not (H.mem decl_types t) then raise (Error (UnknownType t)) ) + (ret::args); + H.add decl_symbs f (Symbols.name f, args, ret) + + let type_of s = let _, args, ret = H.find decl_symbs s in args, ret + + let declared s = + let res = H.mem decl_symbs s in + if not res then begin + eprintf "Not declared : %a in@." Hstring.print s; + H.iter (fun hs (sy, _, _) -> + eprintf "%a (=?%b) -> %a@." Hstring.print hs + (Hstring.compare hs s = 0) + Symbols.print sy) + decl_symbs; + end; + res + + let not_builtin ty = Hstring.equal ty Type.type_proc || + not (Hstring.equal ty Type.type_int || Hstring.equal ty Type.type_real || + Hstring.equal ty Type.type_bool || Hstring.equal ty Type.type_proc) + + let has_abstract_type s = + let _, ret = type_of s in + match H.find decl_types ret with + | Ty.Tabstract _ -> true + | _ -> false + + let has_type_proc s = + Hstring.equal (snd (type_of s)) Type.type_proc + + let _ = + H.add decl_symbs htrue (Symbols.True, [], Type.type_bool); + H.add decl_symbs hfalse (Symbols.False, [], Type.type_bool); + +end + + +module Variant = struct + + let constructors = H.create 17 + let assignments = H.create 17 + + let find t x = try H.find t x with Not_found -> HSet.empty + + let add t x v = + let s = find t x in + H.replace t x (HSet.add v s) + + let assign_constr = add constructors + + let assign_var x y = + if not (Hstring.equal x y) then + add assignments x y + + let rec compute () = + let flag = ref false in + let visited = ref HSet.empty in + let rec dfs x s = + if not (HSet.mem x !visited) then + begin + visited := HSet.add x !visited; + HSet.iter + (fun y -> + let c_x = find constructors x in + let c_y = find constructors y in + let c = HSet.union c_x c_y in + if not (HSet.equal c c_x) then + begin + H.replace constructors x c; + flag := true + end; + dfs y (find assignments y) + ) s + end + in + H.iter dfs assignments; + if !flag then compute () + + let hset_print fmt s = + HSet.iter (fun c -> Format.eprintf "%a, " Hstring.print c) s + + let print () = + H.iter + (fun x c -> + Format.eprintf "%a = {%a}@." Hstring.print x hset_print c) + constructors + + + let get_variants = H.find constructors + + let set_of_list = List.fold_left (fun s x -> HSet.add x s) HSet.empty + + let init l = + compute (); + List.iter + (fun (x, nty) -> + if not (H.mem constructors x) then + let ty = H.find decl_types nty in + match ty with + | Ty.Tsum (_, l) -> + H.add constructors x (set_of_list l) + | _ -> ()) l; + H.clear assignments + + let update_decl_types s = + let nty = ref "" in + let l = ref [] in + HSet.iter + (fun x -> + l := x :: !l; + let vx = Hstring.view x in + nty := if !nty = "" then vx else !nty ^ "|" ^ vx) s; + let nty = Hstring.make !nty in + let ty = Ty.Tsum (nty, List.rev !l) in + H.replace decl_types nty ty; + nty + + let close () = + compute (); + H.iter + (fun x s -> + let nty = update_decl_types s in + let sy, args, _ = H.find decl_symbs x in + H.replace decl_symbs x (sy, args, nty)) + constructors + +end + + +module rec Term : sig + + type t = T of AETerm.t | Tite of Formula.t * t * t + + type operator = Plus | Minus | Mult | Div | Modulo + + val first_ite : t list -> t list * (Formula.t * t * t) * t list + val make_int : Num.num -> t + val make_real : Num.num -> t + val make_app : Symbol.t -> t list -> t + val make_arith : operator -> t -> t -> t + val make_ite : Formula.t -> t -> t -> t + val is_int : t -> bool + val is_real : t -> bool + val t_true : t + val t_false : t + +end += struct + + type t = T of AETerm.t | Tite of Formula.t * t * t + type operator = Plus | Minus | Mult | Div | Modulo + + let make_int i = T (AETerm.int (Num.string_of_num i)) + + let make_real r = T (AETerm.real (Num.string_of_num r)) + + let rec first_ite = function + | [] -> raise Not_found + | Tite (c, t1, t2) :: l -> [], (c, t1, t2), l + | x :: l -> + let left, triplet, right = first_ite l in + x::left, triplet, right + + let rec lift_ite sb l ty = + try + let left, (c, t1, t2), right = first_ite l in + let l = lift_ite sb (left@(t1::right)) ty in + let r = lift_ite sb (left@(t2::right)) ty in + Tite (c, l, r) + with Not_found -> + let l = List.map (function T x -> x | _ -> assert false) l in + T (AETerm.make sb l ty) + + let make_app s l = + try + let (sb, _, nty) = H.find decl_symbs s in + let ty = H.find decl_types nty in + lift_ite sb l ty + with Not_found -> raise (Error (UnknownSymb s)) + + let t_true = T AETerm.vrai + let t_false = T AETerm.faux + + let rec is_int = function + | T t -> AETerm.is_int t + | Tite(_, t1, t2) -> is_int t1 && is_int t2 + + let rec is_real = function + | T t -> AETerm.is_real t + | Tite(_, t1, t2) -> is_real t1 && is_real t2 + + let make_arith op t1 t2 = + let op = + match op with + | Plus -> Symbols.Plus + | Minus -> Symbols.Minus + | Mult -> Symbols.Mult + | Div -> Symbols.Div + | Modulo -> Symbols.Modulo + in + let ty = + if is_int t1 && is_int t2 then Ty.Tint + else if is_real t1 && is_real t2 then Ty.Treal + else assert false + in + lift_ite (Symbols.Op op) [t1; t2] ty + + let make_ite l t1 t2 = Tite (l, t1, t2) + + +end + +and Formula : sig + + type comparator = Eq | Neq | Le | Lt + type combinator = And | Or | Imp | Not + type t = + | Lit of Literal.LT.t + | Comb of combinator * t list + + val f_true : t + val f_false : t + val make_lit : comparator -> Term.t list -> t + val make : combinator -> t list -> t + val make_cnf : t -> Literal.LT.t list list + + val print_list : string -> Format.formatter -> t list -> unit + val print : Format.formatter -> t -> unit + + module Tseitin (Dymmy : sig end) : + sig val make_cnf : t -> Literal.LT.t list list end + +end += struct + + type comparator = Eq | Neq | Le | Lt + type combinator = And | Or | Imp | Not + + type t = + | Lit of Literal.LT.t + | Comb of combinator * t list + + let rec print fmt phi = + match phi with + | Lit a -> Literal.LT.print fmt a + | Comb (Not, [f]) -> + fprintf fmt "not (%a)" print f + | Comb (And, l) -> fprintf fmt "(%a)" (print_list "and") l + | Comb (Or, l) -> fprintf fmt "(%a)" (print_list "or") l + | Comb (Imp, [f1; f2]) -> + fprintf fmt "(%a => %a)" print f1 print f2 + | _ -> assert false + and print_list sep fmt = function + | [] -> () + | [f] -> print fmt f + | f::l -> fprintf fmt "%a %s %a" print f sep (print_list sep) l + + let f_true = Lit Literal.LT.vrai + let f_false = Lit Literal.LT.faux + + let make comb l = Comb (comb, l) + + let value env c = + if List.mem c env then Some true + else if List.mem (make Not [c]) env then Some false + else None + + let rec lift_ite env op l = + try + let left, (c, t1, t2), right = Term.first_ite l in + begin + match value env c with + | Some true -> + lift_ite (c::env) op (left@(t1::right)) + | Some false -> + lift_ite ((make Not [c])::env) op (left@(t2::right)) + | None -> + Comb + (And, + [Comb + (Imp, [c; lift_ite (c::env) op (left@(t1::right))]); + Comb (Imp, + [(make Not [c]); + lift_ite + ((make Not [c])::env) op (left@(t2::right))])]) + end + with Not_found -> + begin + let lit = + match op, l with + | Eq, [Term.T t1; Term.T t2] -> + Literal.Eq (t1, t2) + | Neq, ts -> + let ts = + List.map (function Term.T x -> x | _ -> assert false) ts in + Literal.Distinct (false, ts) + | Le, [Term.T t1; Term.T t2] -> + Literal.Builtin (true, Hstring.make "<=", [t1; t2]) + | Lt, [Term.T t1; Term.T t2] -> + Literal.Builtin (true, Hstring.make "<", [t1; t2]) + | _ -> assert false + in + Lit (Literal.LT.make lit) + end + + let make_lit op l = lift_ite [] op l + + let rec sform = function + | Comb (Not, [Lit a]) -> Lit (Literal.LT.neg a) + | Comb (Not, [Comb (Not, [f])]) -> sform f + | Comb (Not, [Comb (Or, l)]) -> + let nl = List.map (fun a -> sform (Comb (Not, [a]))) l in + Comb (And, nl) + | Comb (Not, [Comb (And, l)]) -> + let nl = List.map (fun a -> sform (Comb (Not, [a]))) l in + Comb (Or, nl) + | Comb (Not, [Comb (Imp, [f1; f2])]) -> + Comb (And, [sform f1; sform (Comb (Not, [f2]))]) + | Comb (And, l) -> + Comb (And, List.map sform l) + | Comb (Or, l) -> + Comb (Or, List.map sform l) + | Comb (Imp, [f1; f2]) -> + Comb (Or, [sform (Comb (Not, [f1])); sform f2]) + | Comb (Imp, _) -> assert false + | f -> f + + let make_or = function + | [] -> assert false + | [a] -> a + | l -> Comb (Or, l) + + let distrib l_and l_or = + let l = + if l_or = [] then l_and + else + List.map + (fun x -> + match x with + | Lit _ -> Comb (Or, x::l_or) + | Comb (Or, l) -> Comb (Or, l@l_or) + | _ -> assert false + ) l_and + in + Comb (And, l) + + let rec flatten_or = function + | [] -> [] + | Comb (Or, l)::r -> l@(flatten_or r) + | Lit a :: r -> (Lit a)::(flatten_or r) + | _ -> assert false + + let rec flatten_and = function + | [] -> [] + | Comb (And, l)::r -> l@(flatten_and r) + | a :: r -> a::(flatten_and r) + + + let rec cnf f = + match f with + | Comb (Or, l) -> + begin + let l = List.map cnf l in + let l_and, l_or = + List.partition (function Comb(And,_) -> true | _ -> false) l in + match l_and with + | [ Comb(And, l_conj) ] -> + let u = flatten_or l_or in + distrib l_conj u + + | Comb(And, l_conj) :: r -> + let u = flatten_or l_or in + cnf (Comb(Or, (distrib l_conj u)::r)) + + | _ -> + begin + match flatten_or l_or with + | [] -> assert false + | [r] -> r + | v -> Comb (Or, v) + end + end + | Comb (And, l) -> + Comb (And, List.map cnf l) + | f -> f + + + let ( @@ ) l1 l2 = List.rev_append l1 l2 + + let rec mk_cnf = function + | Comb (And, l) -> + List.fold_left (fun acc f -> (mk_cnf f) @@ acc) [] l + + | Comb (Or, [f1;f2]) -> + let ll1 = mk_cnf f1 in + let ll2 = mk_cnf f2 in + List.fold_left + (fun acc l1 -> (List.rev_map (fun l2 -> l1 @@ l2)ll2) @@ acc) [] ll1 + + | Comb (Or, f1 :: l) -> + let ll1 = mk_cnf f1 in + let ll2 = mk_cnf (Comb (Or, l)) in + List.fold_left + (fun acc l1 -> (List.rev_map (fun l2 -> l1 @@ l2)ll2) @@ acc) [] ll1 + + | Lit a -> [[a]] + | Comb (Not, [Lit a]) -> [[Literal.LT.neg a]] + | _ -> assert false + + + let rec unfold mono f = + match f with + | Lit a -> a::mono + | Comb (Not, [Lit a]) -> + (Literal.LT.neg a)::mono + | Comb (Or, l) -> + List.fold_left unfold mono l + | _ -> assert false + + let rec init monos f = + match f with + | Comb (And, l) -> + List.fold_left init monos l + | f -> (unfold [] f)::monos + + let make_cnf f = + let sfnc = cnf (sform f) in + init [] sfnc + + let mk_proxy = + let cpt = ref 0 in + fun () -> + let t = AETerm.make + (Symbols.name (Hstring.make ("PROXY__"^(string_of_int !cpt)))) + [] Ty.Tbool + in + incr cpt; + Literal.LT.make (Literal.Eq (t, AETerm.vrai)) + + module Tseitin (Dummy : sig end)= struct + let acc_or = ref [] + let acc_and = ref [] + + let rec cnf f = match f with + | Lit a -> None, [a] + | Comb (Not, [Lit a]) -> None, [Literal.LT.neg a] + + | Comb (And, l) -> + List.fold_left + (fun (_, acc) f -> + match cnf f with + | _, [] -> assert false + | cmb, [a] -> cmb, a :: acc + | Some And, l -> + Some And, l @ acc + (* let proxy = mk_proxy () in *) + (* acc_and := (proxy, l) :: !acc_and; *) + (* proxy :: acc *) + | Some Or, l -> + let proxy = mk_proxy () in + acc_or := (proxy, l) :: !acc_or; + Some And, proxy :: acc + | _ -> assert false + ) (None, []) l + + | Comb (Or, l) -> + List.fold_left + (fun (_, acc) f -> + match cnf f with + | _, [] -> assert false + | cmb, [a] -> cmb, a :: acc + | Some Or, l -> + Some Or, l @ acc + (* let proxy = mk_proxy () in *) + (* acc_or := (proxy, l) :: !acc_or; *) + (* proxy :: acc *) + | Some And, l -> + let proxy = mk_proxy () in + acc_and := (proxy, l) :: !acc_and; + Some Or, proxy :: acc + | _ -> assert false + ) (None, []) l + + | _ -> assert false + + let cnf f = + let acc = match f with + | Comb (And, l) -> List.rev_map (fun f -> snd(cnf f)) l + | _ -> [snd (cnf f)] + in + let proxies = ref [] in + let acc = + List.fold_left + (fun acc (p,l) -> + proxies := p :: !proxies; + let np = Literal.LT.neg p in + let cl, acc = + List.fold_left + (fun (cl,acc) a -> (Literal.LT.neg a :: cl), [np; a] :: acc) + ([p],acc) l in + cl :: acc + )acc !acc_and + in + let acc = + List.fold_left + (fun acc (p,l) -> + proxies := p :: !proxies; + let acc = List.fold_left (fun acc a -> [p; Literal.LT.neg a]::acc) + acc l in + (Literal.LT.neg p :: l) :: acc + ) acc !acc_or + in + acc + + let make_cnf f = + acc_or := []; + acc_and := []; + cnf (sform f) + + (* Naive CNF *) + let make_cnf f = mk_cnf (sform f) + end + +end + +exception Unsat of int list + +let set_cc b = Cc.cc_active := b + +module type Solver = sig + type state + + val get_time : unit -> float + val get_calls : unit -> int + + val clear : unit -> unit + val assume : ?profiling:bool -> id:int -> Formula.t -> unit + val check : ?profiling:bool -> unit -> unit + + val save_state : unit -> state + val restore_state : state -> unit + val entails : ?profiling:bool -> id:int -> Formula.t -> bool +end + +module Make (Dummy : sig end) = struct + + let calls = ref 0 + module Time = Timer.Make (Dummy) + + let get_time = Time.get + let get_calls () = !calls + + module Tseitin = Formula.Tseitin (Dummy) + module CSolver = Solver.Make (Dummy) + + let clear () = CSolver.clear () + + let check_unsatcore uc = + eprintf "Unsat Core : @."; + List.iter + (fun c -> + eprintf "%a@." (Formula.print_list "or") + (List.map (fun x -> Formula.Lit x) c)) uc; + eprintf "@."; + try + clear (); + CSolver.assume uc 0; + CSolver.solve (); + eprintf "Not an unsat core !!!@."; + assert false + with + | Solver.Unsat _ -> (); + | Solver.Sat -> + eprintf "Sat: Not an unsat core !!!@."; + assert false + + let export_unsatcore cl = + let uc = List.map (fun {Solver_types.atoms=atoms} -> + let l = ref [] in + for i = 0 to Vec.size atoms - 1 do + l := (Vec.get atoms i).Solver_types.lit :: !l + done; + !l) cl + in (* check_unsatcore uc; *) + uc + + module SInt = + Set.Make (struct type t = int let compare = Pervasives.compare end) + + let export_unsatcore2 cl = + let s = + List.fold_left + (fun s {Solver_types.name = n} -> + try SInt.add (int_of_string n) s with _ -> s) SInt.empty cl + in + SInt.elements s + + let assume ?(profiling = false) ~id f = + if profiling then Time.start (); + try + CSolver.assume (Tseitin.make_cnf f) id; + if profiling then Time.pause () + with Solver.Unsat ex -> + if profiling then Time.pause (); + raise (Unsat (export_unsatcore2 ex)) + + let check ?(profiling = false) () = + incr calls; + if profiling then Time.start (); + try + CSolver.solve (); + if profiling then Time.pause () + with + | Solver.Sat -> if profiling then Time.pause () + | Solver.Unsat ex -> + if profiling then Time.pause (); + raise (Unsat (export_unsatcore2 ex)) + + type state = CSolver.state + + let save_state = CSolver.save + + let restore_state = CSolver.restore + + let entails ?(profiling=false) ~id f = + let st = save_state () in + let ans = + try + assume ~profiling ~id (Formula.make Formula.Not [f]) ; + check ~profiling (); + false + with Unsat _ -> true + in + restore_state st; + ans + +end diff --git a/smt/smt.mli b/smt/smt.mli new file mode 100644 index 00000000..b01c3b77 --- /dev/null +++ b/smt/smt.mli @@ -0,0 +1,311 @@ +(**************************************************************************) +(* *) +(* Alt-Ergo Zero *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +(** {b The Alt-Ergo Zero SMT library} + + This SMT solver is derived from {{:http://alt-ergo.lri.fr} Alt-Ergo}. It + uses an efficient SAT solver and supports the following quantifier free + theories: + - Equality and uninterpreted functions + - Arithmetic (linear, non-linear, integer, reals) + - Enumerated data-types + + This API makes heavy use of hash-consed strings. Please take a moment to + look at {! Hstring}. +*) + +(** {2 Error handling } *) + +type error = + | DuplicateTypeName of Hstring.t (** raised when a type is already declared *) + | DuplicateSymb of Hstring.t (** raised when a symbol is already declared *) + | UnknownType of Hstring.t (** raised when the given type is not declared *) + | UnknownSymb of Hstring.t (** raised when the given symbol is not declared *) + +exception Error of error + +(** {2 Typing } *) + +(** {3 Typing } *) +module Type : sig + + type t = Hstring.t + (** The type of types in Alt-Ergo Zero *) + + (** {4 Builtin types } *) + + val type_int : t + (** The type of integers *) + + val type_real : t + (** The type of reals *) + + val type_bool : t + (** The type of booleans *) + + val type_proc : t + (** The type processes (identifiers) *) + + (** {4 Declaring new types } *) + + val declare : Hstring.t -> Hstring.t list -> unit + (** {ul {- [declare n cstrs] declares a new enumerated data-type with + name [n] and constructors [cstrs].} + {- [declare n []] declares a new abstract type with name [n].}}*) + + val all_constructors : unit -> Hstring.t list + (** [all_constructors ()] returns a list of all the defined constructors. *) + + val constructors : t -> Hstring.t list + (** [constructors ty] returns the list of constructors of [ty] when type is + an enumerated data-type, otherwise returns [[]].*) + +end + + +(** {3 Function symbols} *) +module Symbol : sig + + type t = Hstring.t + (** The type of function symbols *) + + val declare : Hstring.t -> Type.t list -> Type.t -> unit + (** [declare s [arg_1; ... ; arg_n] out] declares a new function + symbol with type [ (arg_1, ... , arg_n) -> out] *) + + val type_of : t -> Type.t list * Type.t + (** [type_of x] returns the type of x. *) + + val has_abstract_type : t -> bool + (** [has_abstract_type x] is [true] if the type of x is abstract. *) + + val has_type_proc : t -> bool + (** [has_type_proc x] is [true] if x has the type of a process + identifier. *) + + val declared : t -> bool + (** [declared x] is [true] if [x] is already declared. *) + +end + +(** {3 Variants} + + The types of symbols (when they are enumerated data types) can be refined + to substypes of their original type (i.e. a subset of their constructors). +*) +module Variant : sig + + val init : (Symbol.t * Type.t) list -> unit + (** [init l] where [l] is a list of pairs [(s, ty)] initializes the + type (and associated constructors) of each [s] to its original type [ty]. + + This function must be called with a list of all symbols before + attempting to refine the types. *) + + val close : unit -> unit + (** [close ()] will compute the smallest type possible for each symbol. + + This function must be called when all information has been added.*) + + val assign_constr : Symbol.t -> Hstring.t -> unit + (** [assign_constr s cstr] will add the constraint that the constructor + [cstr] must be in the type of [s] *) + + val assign_var : Symbol.t -> Symbol.t -> unit + (** [assign_var x y] will add the constraint that the type of [y] is a + subtype of [x] (use this function when [x := y] appear in your + program *) + + val print : unit -> unit + (** [print ()] will output the computed refined types on std_err. This + function is here only for debugging purposes. Use it afer [close ()].*) + + val get_variants : Symbol.t -> Hstring.HSet.t + (** [get_variants s] returns a set of constructors, which is the refined + type of [s].*) + +end + +(** {2 Building terms} *) + +module rec Term : sig + + type t + (** The type of terms *) + + (** The type of operators *) + type operator = + | Plus (** [+] *) + | Minus (** [-] *) + | Mult (** [*] *) + | Div (** [/] *) + | Modulo (** [mod] *) + + val make_int : Num.num -> t + (** [make_int n] creates an integer constant of value [n]. *) + + val make_real : Num.num -> t + (** [make_real n] creates an real constant of value [n]. *) + + val make_app : Symbol.t -> t list -> t + (** [make_app f l] creates the application of function symbol [f] to a list + of terms [l]. *) + + val make_arith : operator -> t -> t -> t + (** [make_arith op t1 t2] creates the term [t1 t2]. *) + + val make_ite : Formula.t -> t -> t -> t + (** [make_ite f t1 t2] creates the term [if f then t1 else t2]. *) + + val is_int : t -> bool + (** [is_int x] is [true] if the term [x] has type int *) + + val is_real : t -> bool + (** [is_real x] is [true] if the term [x] has type real *) + + val t_true : t + (** [t_true] is the boolean term [true] *) + + val t_false : t + (** [t_false] is the boolean term [false] *) + +end + + +(** {2 Building formulas} *) + +and Formula : sig + + (** The type of comparators: *) + type comparator = + | Eq (** equality ([=]) *) + | Neq (** disequality ([<>]) *) + | Le (** inequality ([<=]) *) + | Lt (** strict inequality ([<]) *) + + (** The type of operators *) + type combinator = + | And (** conjunction *) + | Or (** disjunction *) + | Imp (** implication *) + | Not (** negation *) + + (** The type of ground formulas *) + type t = + | Lit of Literal.LT.t + | Comb of combinator * t list + + val f_true : t + (** The formula which represents [true]*) + + val f_false : t + (** The formula which represents [false]*) + + val make_lit : comparator -> Term.t list -> t + (** [make_lit cmp [t1; t2]] creates the literal [(t1 t2)]. *) + + val make : combinator -> t list -> t + (** [make cmb [f_1; ...; f_n]] creates the formula + [(f_1 ... f_n)].*) + + val make_cnf : t -> Literal.LT.t list list + (** [make_cnf f] returns a conjunctive normal form of [f] under the form: a + list (which is a conjunction) of lists (which are disjunctions) of + literals. *) + + val print : Format.formatter -> t -> unit + (** [print fmt f] prints the formula on the formatter [fmt].*) + +end + +(** {2 The SMT solver} *) + +exception Unsat of int list +(** The exception raised by {! Smt.Solver.check} and {! Smt.Solver.assume} when + the formula is unsatisfiable. *) + +val set_cc : bool -> unit +(** set_cc [false] deactivates congruence closure algorithm + ([true] by default).*) + +module type Solver = sig + + (** This SMT solver is imperative in the sense that it maintains a global + context. To create different instances of Alt-Ergo Zero use the + functor {! Smt.Make}. + + A typical use of this solver is to do the following :{[ + clear (); + assume f_1; + ... + assume f_n; + check ();]} + *) + + type state + (** The type of the internal state of the solver (see {!save_state} and + {!restore_state}).*) + + + (** {2 Profiling functions} *) + + val get_time : unit -> float + (** [get_time ()] returns the cumulated time spent in the solver in seconds.*) + + val get_calls : unit -> int + (** [get_calls ()] returns the cumulated number of calls to {! check}.*) + + (** {2 Main API of the solver} *) + + val clear : unit -> unit + (** [clear ()] clears the context of the solver. Use this after {! check} + raised {! Unsat} or if you want to restart the solver. *) + + + val assume : ?profiling:bool -> id:int -> Formula.t -> unit + (** [assume ~profiling:b f id] adds the formula [f] to the context of the + solver with idetifier [id]. + This function only performs unit propagation. + + @param profiling if set to [true] then profiling information (time) will + be computed (expensive because of system calls). + + {b Raises} {! Unsat} if the context becomes inconsistent after unit + propagation. *) + + val check : ?profiling:bool -> unit -> unit + (** [check ()] runs Alt-Ergo Zero on its context. If [()] is + returned then the context is satifiable. + + @param profiling if set to [true] then profiling information (time) will + be computed (expensive because of system calls). + + {b Raises} {! Unsat} [[id_1; ...; id_n]] if the context is unsatisfiable. + [id_1, ..., id_n] is the unsat core (returned as the identifiers of the + formulas given to the solver). *) + + val save_state : unit -> state + (** [save_state ()] returns a {b copy} of the current state of the solver.*) + + val restore_state : state -> unit + (** [restore_state s] restores a previously saved state [s].*) + + val entails : ?profiling:bool -> id:int -> Formula.t -> bool + (** [entails ~id f] returns [true] if the context of the solver entails + the formula [f]. It doesn't modify the context of the solver (the state + is saved when this function is called and restored on exit).*) + +end + +(** Functor to create several instances of the solver *) +module Make (Dummy : sig end) : Solver + diff --git a/smt/solver.ml b/smt/solver.ml new file mode 100644 index 00000000..22f519ce --- /dev/null +++ b/smt/solver.ml @@ -0,0 +1,1030 @@ +(**************************************************************************) +(* *) +(* Alt-Ergo Zero *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Solver_types +open Format + +module Th = Cc.Make(Combine.CX) +module Ex = Explanation + +exception Sat +exception Unsat of clause list +exception Restart + + + +type env = + { + (* si vrai, les contraintes sont deja fausses *) + mutable is_unsat : bool; + + mutable unsat_core : clause list; + + (* clauses du probleme *) + mutable clauses : clause Vec.t; + + (* clauses apprises *) + mutable learnts : clause Vec.t; + + (* valeur de l'increment pour l'activite des clauses *) + mutable clause_inc : float; + + (* valeur de l'increment pour l'activite des variables *) + mutable var_inc : float; + + (* un vecteur des variables du probleme *) + mutable vars : var Vec.t; + + (* la pile de decisions avec les faits impliques *) + mutable trail : atom Vec.t; + + (* une pile qui pointe vers les niveaux de decision dans trail *) + mutable trail_lim : int Vec.t; + + (* Tete de la File des faits unitaires a propager. + C'est un index vers le trail *) + mutable qhead : int; + + (* Nombre des assignements top-level depuis la derniere + execution de 'simplify()' *) + mutable simpDB_assigns : int; + + (* Nombre restant de propagations a faire avant la prochaine + execution de 'simplify()' *) + mutable simpDB_props : int; + + (* Un tas ordone en fonction de l'activite des variables *) + mutable order : Iheap.t; + + (* estimation de progressions, mis a jour par 'search()' *) + mutable progress_estimate : float; + + (* *) + remove_satisfied : bool; + + (* inverse du facteur d'acitivte des variables, vaut 1/0.999 par defaut *) + var_decay : float; + + (* inverse du facteur d'activite des clauses, vaut 1/0.95 par defaut *) + clause_decay : float; + + (* la limite de restart initiale, vaut 100 par defaut *) + mutable restart_first : int; + + (* facteur de multiplication de restart limite, vaut 1.5 par defaut*) + restart_inc : float; + + (* limite initiale du nombre de clause apprises, vaut 1/3 + des clauses originales par defaut *) + mutable learntsize_factor : float; + + (* multiplier learntsize_factor par cette valeur a chaque restart, + vaut 1.1 par defaut *) + learntsize_inc : float; + + (* controler la minimisation des clauses conflit, vaut true par defaut *) + expensive_ccmin : bool; + + (* controle la polarite a choisir lors de la decision *) + polarity_mode : bool; + + mutable starts : int; + + mutable decisions : int; + + mutable propagations : int; + + mutable conflicts : int; + + mutable clauses_literals : int; + + mutable learnts_literals : int; + + mutable max_literals : int; + + mutable tot_literals : int; + + mutable nb_init_vars : int; + + mutable nb_init_clauses : int; + + mutable model : var Vec.t; + + mutable tenv : Th.t; + + mutable tenv_queue : Th.t Vec.t; + + mutable tatoms_queue : atom Queue.t; + + } + + + +exception Conflict of clause +module Make (Dummy : sig end) = struct + + module Solver_types = Solver_types.Make(struct end) + + open Solver_types + + type state = + { + env : env; + st_cpt_mk_var: int; + st_ma : var Literal.LT.Map.t; + } + + + let env = + { + is_unsat = false; + + unsat_core = [] ; + + clauses = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*) + + learnts = Vec.make 0 dummy_clause; (*sera mis a jour lors du parsing*) + + clause_inc = 1.; + + var_inc = 1.; + + vars = Vec.make 0 dummy_var; (*sera mis a jour lors du parsing*) + + trail = Vec.make 601 dummy_atom; + + trail_lim = Vec.make 601 (-105); + + qhead = 0; + + simpDB_assigns = -1; + + simpDB_props = 0; + + order = Iheap.init 0; (* sera mis a jour dans solve *) + + progress_estimate = 0.; + + remove_satisfied = true; + + var_decay = 1. /. 0.95; + + clause_decay = 1. /. 0.999; + + restart_first = 100; + + restart_inc = 1.5; + + learntsize_factor = 1. /. 3. ; + + learntsize_inc = 1.1; + + expensive_ccmin = true; + + polarity_mode = false; + + starts = 0; + + decisions = 0; + + propagations = 0; + + conflicts = 0; + + clauses_literals = 0; + + learnts_literals = 0; + + max_literals = 0; + + tot_literals = 0; + + nb_init_vars = 0; + + nb_init_clauses = 0; + + model = Vec.make 0 dummy_var; + + tenv = Th.empty(); + + tenv_queue = Vec.make 100 (Th.empty()); + + tatoms_queue = Queue.create (); + + } + + +let f_weight i j = (Vec.get env.vars j).weight < (Vec.get env.vars i).weight + +let f_filter i = (Vec.get env.vars i).level < 0 + +let insert_var_order v = + Iheap.insert f_weight env.order v.vid + +let var_decay_activity () = env.var_inc <- env.var_inc *. env.var_decay + +let clause_decay_activity () = + env.clause_inc <- env.clause_inc *. env.clause_decay + +let var_bump_activity v = + v.weight <- v.weight +. env.var_inc; + if v.weight > 1e100 then begin + for i = 0 to env.vars.Vec.sz - 1 do + (Vec.get env.vars i).weight <- (Vec.get env.vars i).weight *. 1e-100 + done; + env.var_inc <- env.var_inc *. 1e-100; + end; + if Iheap.in_heap env.order v.vid then + Iheap.decrease f_weight env.order v.vid + + +let clause_bump_activity c = + c.activity <- c.activity +. env.clause_inc; + if c.activity > 1e20 then begin + for i = 0 to env.learnts.Vec.sz - 1 do + (Vec.get env.learnts i).activity <- + (Vec.get env.learnts i).activity *. 1e-20; + done; + env.clause_inc <- env.clause_inc *. 1e-20 + end + +let decision_level () = Vec.size env.trail_lim + +let nb_assigns () = Vec.size env.trail +let nb_clauses () = Vec.size env.clauses +let nb_learnts () = Vec.size env.learnts +let nb_vars () = Vec.size env.vars + +let new_decision_level() = + Vec.push env.trail_lim (Vec.size env.trail); + Vec.push env.tenv_queue env.tenv (* save the current tenv *) + +let attach_clause c = + Vec.push (Vec.get c.atoms 0).neg.watched c; + Vec.push (Vec.get c.atoms 1).neg.watched c; + if c.learnt then + env.learnts_literals <- env.learnts_literals + Vec.size c.atoms + else + env.clauses_literals <- env.clauses_literals + Vec.size c.atoms + +let detach_clause c = + c.removed <- true; + (* + Vec.remove (Vec.get c.atoms 0).neg.watched c; + Vec.remove (Vec.get c.atoms 1).neg.watched c; + *) + if c.learnt then + env.learnts_literals <- env.learnts_literals - Vec.size c.atoms + else + env.clauses_literals <- env.clauses_literals - Vec.size c.atoms + +let remove_clause c = detach_clause c + +let satisfied c = + try + for i = 0 to Vec.size c.atoms - 1 do + if (Vec.get c.atoms i).is_true then raise Exit + done; + false + with Exit -> true + +(* annule tout jusqu'a lvl *exclu* *) +let cancel_until lvl = + if decision_level () > lvl then begin + env.qhead <- Vec.get env.trail_lim lvl; + for c = Vec.size env.trail - 1 downto env.qhead do + let a = Vec.get env.trail c in + a.is_true <- false; + a.neg.is_true <- false; + a.var.level <- -1; + a.var.reason <- None; + a.var.vpremise <- []; + insert_var_order a.var + done; + Queue.clear env.tatoms_queue; + env.tenv <- Vec.get env.tenv_queue lvl; (* recover the right tenv *) + Vec.shrink env.trail ((Vec.size env.trail) - env.qhead); + Vec.shrink env.trail_lim ((Vec.size env.trail_lim) - lvl); + Vec.shrink env.tenv_queue ((Vec.size env.tenv_queue) - lvl) + end; + assert (Vec.size env.trail_lim = Vec.size env.tenv_queue) + +let rec pick_branch_lit () = + let max = Iheap.remove_min f_weight env.order in + let v = Vec.get env.vars max in + if v.level>= 0 then begin + assert (v.pa.is_true || v.na.is_true); + pick_branch_lit () + end + else v + +let enqueue a lvl reason = + assert (not a.is_true && not a.neg.is_true && + a.var.level < 0 && a.var.reason = None && lvl >= 0); + (* Garder la reason car elle est utile pour les unsat-core *) + (*let reason = if lvl = 0 then None else reason in*) + a.is_true <- true; + a.var.level <- lvl; + a.var.reason <- reason; + (*eprintf "enqueue: %a@." Debug.atom a; *) + Vec.push env.trail a + +let progress_estimate () = + let prg = ref 0. in + let nbv = to_float (nb_vars()) in + let lvl = decision_level () in + let _F = 1. /. nbv in + for i = 0 to lvl do + let _beg = if i = 0 then 0 else Vec.get env.trail_lim (i-1) in + let _end = if i=lvl then Vec.size env.trail else Vec.get env.trail_lim i in + prg := !prg +. _F**(to_float i) *. (to_float (_end - _beg)) + done; + !prg /. nbv + +let propagate_in_clause a c i watched new_sz = + let atoms = c.atoms in + let first = Vec.get atoms 0 in + if first == a.neg then begin (* le litiral faux doit etre dans .(1) *) + Vec.set atoms 0 (Vec.get atoms 1); + Vec.set atoms 1 first + end; + let first = Vec.get atoms 0 in + if first.is_true then begin + (* clause vraie, la garder dans les watched *) + Vec.set watched !new_sz c; + incr new_sz; + end + else + try (* chercher un nouveau watcher *) + for k = 2 to Vec.size atoms - 1 do + let ak = Vec.get atoms k in + if not (ak.neg.is_true) then begin + (* Watcher Trouve: mettre a jour et sortir *) + Vec.set atoms 1 ak; + Vec.set atoms k a.neg; + Vec.push ak.neg.watched c; + raise Exit + end + done; + (* Watcher NON Trouve *) + if first.neg.is_true then begin + (* la clause est fausse *) + env.qhead <- Vec.size env.trail; + for k = i to Vec.size watched - 1 do + Vec.set watched !new_sz (Vec.get watched k); + incr new_sz; + done; + raise (Conflict c) + end + else begin + (* la clause est unitaire *) + Vec.set watched !new_sz c; + incr new_sz; + enqueue first (decision_level ()) (Some c) + end + with Exit -> () + +let propagate_atom a res = + let watched = a.watched in + let new_sz_w = ref 0 in + begin + try + for i = 0 to Vec.size watched - 1 do + let c = Vec.get watched i in + if not c.removed then propagate_in_clause a c i watched new_sz_w + done; + with Conflict c -> assert (!res = None); res := Some c + end; + let dead_part = Vec.size watched - !new_sz_w in + Vec.shrink watched dead_part + +let expensive_theory_propagate () = None + (* try *) + (* if D1.d then eprintf "expensive_theory_propagate@."; *) + (* ignore(Th.expensive_processing env.tenv); *) + (* if D1.d then eprintf "expensive_theory_propagate => None@."; *) + (* None *) + (* with Exception.Inconsistent dep -> *) + (* if D1.d then eprintf "expensive_theory_propagate => Inconsistent@."; *) + (* Some dep *) + +let theory_propagate () = + let facts = ref [] in + while not (Queue.is_empty env.tatoms_queue) do + let a = Queue.pop env.tatoms_queue in + if a.is_true then + (*let ex = if a.var.level > 0 then Ex.singleton a else Ex.empty in*) + let ex = Ex.singleton a in (* Usefull for debugging *) + facts := (a.lit, ex) :: !facts + else + if a.neg.is_true then + (*let ex = if a.var.level > 0 then Ex.singleton a.neg else Ex.empty in*) + let ex = Ex.singleton a.neg in (* Usefull for debugging *) + facts := (a.neg.lit, ex) :: !facts + else assert false; + done; + try + let full_model = nb_assigns() = env.nb_init_vars in + env.tenv <- + List.fold_left + (fun t (a,ex) -> let t,_,_ = Th.assume ~cs:true a ex t in t) + env.tenv !facts; + if full_model then expensive_theory_propagate () + else None + with Exception.Inconsistent dep -> + (* eprintf "th inconsistent : %a @." Ex.print dep; *) + Some dep + +let propagate () = + let num_props = ref 0 in + let res = ref None in + (*assert (Queue.is_empty env.tqueue);*) + while env.qhead < Vec.size env.trail do + let a = Vec.get env.trail env.qhead in + env.qhead <- env.qhead + 1; + incr num_props; + propagate_atom a res; + Queue.push a env.tatoms_queue; + done; + env.propagations <- env.propagations + !num_props; + env.simpDB_props <- env.simpDB_props - !num_props; + !res + + +let analyze c_clause = + let pathC = ref 0 in + let learnt = ref [] in + let cond = ref true in + let blevel = ref 0 in + let seen = ref [] in + let c = ref c_clause in + let tr_ind = ref (Vec.size env.trail - 1) in + let size = ref 1 in + let history = ref [] in + while !cond do + if !c.learnt then clause_bump_activity !c; + history := !c :: !history; + (* visit the current predecessors *) + for j = 0 to Vec.size !c.atoms - 1 do + let q = Vec.get !c.atoms j in + (*printf "I visit %a@." D1.atom q;*) + assert (q.is_true || q.neg.is_true && q.var.level >= 0); (* Pas sur *) + if not q.var.seen && q.var.level > 0 then begin + var_bump_activity q.var; + q.var.seen <- true; + seen := q :: !seen; + if q.var.level >= decision_level () then incr pathC + else begin + learnt := q :: !learnt; + incr size; + blevel := max !blevel q.var.level + end + end + done; + + (* look for the next node to expand *) + while not (Vec.get env.trail !tr_ind).var.seen do decr tr_ind done; + decr pathC; + let p = Vec.get env.trail !tr_ind in + decr tr_ind; + match !pathC, p.var.reason with + | 0, _ -> + cond := false; + learnt := p.neg :: (List.rev !learnt) + | n, None -> assert false + | n, Some cl -> c := cl + done; + List.iter (fun q -> q.var.seen <- false) !seen; + !blevel, !learnt, !history, !size + +let f_sort_db c1 c2 = + let sz1 = Vec.size c1.atoms in + let sz2 = Vec.size c2.atoms in + let c = compare c1.activity c2.activity in + if sz1 = sz2 && c = 0 then 0 + else + if sz1 > 2 && (sz2 = 2 || c < 0) then -1 + else 1 + +let locked c = false(* + try + for i = 0 to Vec.size env.vars - 1 do + match (Vec.get env.vars i).reason with + | Some c' when c ==c' -> raise Exit + | _ -> () + done; + false + with Exit -> true*) + +let reduce_db () = () +(* + let extra_lim = env.clause_inc /. (to_float (Vec.size env.learnts)) in + Vec.sort env.learnts f_sort_db; + let lim2 = Vec.size env.learnts in + let lim1 = lim2 / 2 in + let j = ref 0 in + for i = 0 to lim1 - 1 do + let c = Vec.get env.learnts i in + if Vec.size c.atoms > 2 && not (locked c) then + remove_clause c + else + begin Vec.set env.learnts !j c; incr j end + done; + for i = lim1 to lim2 - 1 do + let c = Vec.get env.learnts i in + if Vec.size c.atoms > 2 && not (locked c) && c.activity < extra_lim then + remove_clause c + else + begin Vec.set env.learnts !j c; incr j end + done; + Vec.shrink env.learnts (lim2 - !j) +*) + +let remove_satisfied vec = + let j = ref 0 in + let k = Vec.size vec - 1 in + for i = 0 to k do + let c = Vec.get vec i in + if satisfied c then remove_clause c + else begin + Vec.set vec !j (Vec.get vec i); + incr j + end + done; + Vec.shrink vec (k + 1 - !j) + + +module HUC = Hashtbl.Make + (struct type t = clause let equal = (==) let hash = Hashtbl.hash end) + + +let report_b_unsat ({atoms=atoms} as confl) = + let l = ref [confl] in + for i = 0 to Vec.size atoms - 1 do + let v = (Vec.get atoms i).var in + l := List.rev_append v.vpremise !l; + match v.reason with None -> () | Some c -> l := c :: !l + done; + if false then begin + eprintf "@.>>UNSAT Deduction made from:@."; + List.iter + (fun hc -> + eprintf " %a@." Debug.clause hc + )!l; + end; + let uc = HUC.create 17 in + let rec roots todo = + match todo with + | [] -> () + | c::r -> + for i = 0 to Vec.size c.atoms - 1 do + let v = (Vec.get c.atoms i).var in + if not v.seen then begin + v.seen <- true; + roots v.vpremise; + match v.reason with None -> () | Some r -> roots [r]; + end + done; + match c.cpremise with + | [] -> if not (HUC.mem uc c) then HUC.add uc c (); roots r + | prems -> roots prems; roots r + in roots !l; + let unsat_core = HUC.fold (fun c _ l -> c :: l) uc [] in + if false then begin + eprintf "@.>>UNSAT_CORE:@."; + List.iter + (fun hc -> + eprintf " %a@." Debug.clause hc + )unsat_core; + end; + env.is_unsat <- true; + env.unsat_core <- unsat_core; + raise (Unsat unsat_core) + + +let report_t_unsat dep = + let l = + Ex.fold_atoms + (fun {var=v} l -> + let l = List.rev_append v.vpremise l in + match v.reason with None -> l | Some c -> c :: l + ) dep [] + in + if false then begin + eprintf "@.>>T-UNSAT Deduction made from:@."; + List.iter + (fun hc -> + eprintf " %a@." Debug.clause hc + )l; + end; + let uc = HUC.create 17 in + let rec roots todo = + match todo with + | [] -> () + | c::r -> + for i = 0 to Vec.size c.atoms - 1 do + let v = (Vec.get c.atoms i).var in + if not v.seen then begin + v.seen <- true; + roots v.vpremise; + match v.reason with None -> () | Some r -> roots [r]; + end + done; + match c.cpremise with + | [] -> if not (HUC.mem uc c) then HUC.add uc c (); roots r + | prems -> roots prems; roots r + in roots l; + let unsat_core = HUC.fold (fun c _ l -> c :: l) uc [] in + if false then begin + eprintf "@.>>T-UNSAT_CORE:@."; + List.iter + (fun hc -> + eprintf " %a@." Debug.clause hc + ) unsat_core; + end; + env.is_unsat <- true; + env.unsat_core <- unsat_core; + raise (Unsat unsat_core) + +let simplify () = + assert (decision_level () = 0); + if env.is_unsat then raise (Unsat env.unsat_core); + begin + match propagate () with + | Some confl -> report_b_unsat confl + | None -> + match theory_propagate () with + Some dep -> report_t_unsat dep + | None -> () + end; + if nb_assigns() <> env.simpDB_assigns && env.simpDB_props <= 0 then begin + if Vec.size env.learnts > 0 then remove_satisfied env.learnts; + if env.remove_satisfied then remove_satisfied env.clauses; + (*Iheap.filter env.order f_filter f_weight;*) + env.simpDB_assigns <- nb_assigns (); + env.simpDB_props <- env.clauses_literals + env.learnts_literals; + end + +let record_learnt_clause blevel learnt history size = + begin match learnt with + | [] -> assert false + | [fuip] -> + assert (blevel = 0); + fuip.var.vpremise <- history; + enqueue fuip 0 None + | fuip :: _ -> + let name = fresh_lname () in + let lclause = make_clause name learnt size true history in + Vec.push env.learnts lclause; + attach_clause lclause; + clause_bump_activity lclause; + enqueue fuip blevel (Some lclause) + end; + var_decay_activity (); + clause_decay_activity() + +let check_inconsistence_of dep = + try + let env = ref (Th.empty()) in (); + Ex.iter_atoms + (fun atom -> + let t,_,_ = Th.assume ~cs:true atom.lit (Ex.singleton atom) !env in + env := t) + dep; + (* ignore (Th.expensive_processing !env); *) + assert false + with Exception.Inconsistent _ -> () + +let theory_analyze dep = + let atoms, sz, max_lvl, c_hist = + Ex.fold_atoms + (fun a (acc, sz, max_lvl, c_hist) -> + let c_hist = List.rev_append a.var.vpremise c_hist in + let c_hist = match a.var.reason with + | None -> c_hist | Some r -> r:: c_hist in + if a.var.level = 0 then acc, sz, max_lvl, c_hist + else a.neg :: acc, sz + 1, max max_lvl a.var.level, c_hist + ) dep ([], 0, 0, []) + in + if atoms = [] then begin + (* check_inconsistence_of dep; *) + report_t_unsat dep + (* une conjonction de faits unitaires etaient deja unsat *) + end; + let name = fresh_dname() in + let c_clause = make_clause name atoms sz false c_hist in + (* eprintf "c_clause: %a@." Debug.clause c_clause; *) + c_clause.removed <- true; + + let pathC = ref 0 in + let learnt = ref [] in + let cond = ref true in + let blevel = ref 0 in + let seen = ref [] in + let c = ref c_clause in + let tr_ind = ref (Vec.size env.trail - 1) in + let size = ref 1 in + let history = ref [] in + while !cond do + if !c.learnt then clause_bump_activity !c; + history := !c :: !history; + (* visit the current predecessors *) + for j = 0 to Vec.size !c.atoms - 1 do + let q = Vec.get !c.atoms j in + (*printf "I visit %a@." D1.atom q;*) + assert (q.is_true || q.neg.is_true && q.var.level >= 0); (* Pas sur *) + if not q.var.seen && q.var.level > 0 then begin + var_bump_activity q.var; + q.var.seen <- true; + seen := q :: !seen; + if q.var.level >= max_lvl then incr pathC + else begin + learnt := q :: !learnt; + incr size; + blevel := max !blevel q.var.level + end + end + done; + + (* look for the next node to expand *) + while not (Vec.get env.trail !tr_ind).var.seen do decr tr_ind done; + decr pathC; + let p = Vec.get env.trail !tr_ind in + decr tr_ind; + match !pathC, p.var.reason with + | 0, _ -> + cond := false; + learnt := p.neg :: (List.rev !learnt) + | n, None -> assert false + | n, Some cl -> c := cl + done; + List.iter (fun q -> q.var.seen <- false) !seen; + !blevel, !learnt, !history, !size + + + +let add_boolean_conflict confl = + env.conflicts <- env.conflicts + 1; + if decision_level() = 0 then report_b_unsat confl; (* Top-level conflict *) + let blevel, learnt, history, size = analyze confl in + cancel_until blevel; + record_learnt_clause blevel learnt history size + +let search n_of_conflicts n_of_learnts = + let conflictC = ref 0 in + env.starts <- env.starts + 1; + while (true) do + match propagate () with + | Some confl -> (* Conflict *) + incr conflictC; + add_boolean_conflict confl + + | None -> (* No Conflict *) + match theory_propagate () with + | Some dep -> + incr conflictC; + env.conflicts <- env.conflicts + 1; + if decision_level() = 0 then report_t_unsat dep; (* T-L conflict *) + let blevel, learnt, history, size = theory_analyze dep in + cancel_until blevel; + record_learnt_clause blevel learnt history size + + | None -> + if nb_assigns () = env.nb_init_vars then raise Sat; + if n_of_conflicts >= 0 && !conflictC >= n_of_conflicts then + begin + env.progress_estimate <- progress_estimate(); + cancel_until 0; + raise Restart + end; + if decision_level() = 0 then simplify (); + + if n_of_learnts >= 0 && + Vec.size env.learnts - nb_assigns() >= n_of_learnts then + reduce_db(); + + env.decisions <- env.decisions + 1; + + new_decision_level(); + let next = pick_branch_lit () in + let current_level = decision_level () in + assert (next.level < 0); + (* eprintf "decide: %a@." Debug.atom next.pa; *) + enqueue next.pa current_level None + done + +let check_clause c = + let b = ref false in + let atoms = c.atoms in + for i = 0 to Vec.size atoms - 1 do + let a = Vec.get atoms i in + b := !b || a.is_true + done; + assert (!b) + +let check_vec vec = + for i = 0 to Vec.size vec - 1 do check_clause (Vec.get vec i) done + +let check_model () = + check_vec env.clauses; + check_vec env.learnts + + +let solve () = + if env.is_unsat then raise (Unsat env.unsat_core); + let n_of_conflicts = ref (to_float env.restart_first) in + let n_of_learnts = ref ((to_float (nb_clauses())) *. env.learntsize_factor) in + try + while true do + (try search (to_int !n_of_conflicts) (to_int !n_of_learnts); + with Restart -> ()); + n_of_conflicts := !n_of_conflicts *. env.restart_inc; + n_of_learnts := !n_of_learnts *. env.learntsize_inc; + done; + with + | Sat -> + (*check_model ();*) + raise Sat + | (Unsat cl) as e -> + (* check_unsat_core cl; *) + raise e + +exception Trivial + +let partition atoms init = + let rec partition_aux trues unassigned falses init = function + | [] -> trues @ unassigned @ falses, init + | a::r -> + if a.is_true then + if a.var.level = 0 then raise Trivial + else (a::trues) @ unassigned @ falses @ r, init + else if a.neg.is_true then + if a.var.level = 0 then + partition_aux trues unassigned falses + (List.rev_append (a.var.vpremise) init) r + else partition_aux trues unassigned (a::falses) init r + else partition_aux trues (a::unassigned) falses init r + in + partition_aux [] [] [] init atoms + + +let add_clause ~cnumber atoms = + if env.is_unsat then raise (Unsat env.unsat_core); + let init_name = string_of_int cnumber in + let init0 = make_clause init_name atoms (List.length atoms) false [] in + try + let atoms, init = + if decision_level () = 0 then + let atoms, init = List.fold_left + (fun (atoms, init) a -> + if a.is_true then raise Trivial; + if a.neg.is_true then + atoms, (List.rev_append (a.var.vpremise) init) + else a::atoms, init + ) ([], [init0]) atoms in + List.fast_sort (fun a b -> a.var.vid - b.var.vid) atoms, init + else partition atoms [init0] + in + let size = List.length atoms in + match atoms with + | [] -> + report_b_unsat init0; + + | a::_::_ -> + let name = fresh_name () in + let clause = make_clause name atoms size false init in + attach_clause clause; + Vec.push env.clauses clause; + + if a.neg.is_true then begin + let lvl = List.fold_left (fun m a -> max m a.var.level) 0 atoms in + cancel_until lvl; + add_boolean_conflict clause + end + + | [a] -> + cancel_until 0; + a.var.vpremise <- init; + enqueue a 0 None; + match propagate () with + None -> () | Some confl -> report_b_unsat confl + with Trivial -> () + +let add_clauses cnf ~cnumber = + List.iter (add_clause ~cnumber) cnf; + match theory_propagate () with + None -> () | Some dep -> report_t_unsat dep + +let init_solver cnf ~cnumber = + let nbv, _ = made_vars_info () in + let nbc = env.nb_init_clauses + List.length cnf in + Vec.grow_to_by_double env.vars nbv; + Iheap.grow_to_by_double env.order nbv; + List.iter + (List.iter + (fun a -> + Vec.set env.vars a.var.vid a.var; + insert_var_order a.var + ) + ) cnf; + env.nb_init_vars <- nbv; + Vec.grow_to_by_double env.model nbv; + Vec.grow_to_by_double env.clauses nbc; + Vec.grow_to_by_double env.learnts nbc; + env.nb_init_clauses <- nbc; + add_clauses cnf ~cnumber + + +let assume cnf ~cnumber = + let cnf = List.map (List.map Solver_types.add_atom) cnf in + init_solver cnf ~cnumber + +let clear () = + let empty_theory = Th.empty () in + env.is_unsat <- false; + env.unsat_core <- []; + env.clauses <- Vec.make 0 dummy_clause; + env.learnts <- Vec.make 0 dummy_clause; + env.clause_inc <- 1.; + env.var_inc <- 1.; + env.vars <- Vec.make 0 dummy_var; + env.qhead <- 0; + env.simpDB_assigns <- -1; + env.simpDB_props <- 0; + env.order <- Iheap.init 0; (* sera mis a jour dans solve *) + env.progress_estimate <- 0.; + env.restart_first <- 100; + env.starts <- 0; + env.decisions <- 0; + env.propagations <- 0; + env.conflicts <- 0; + env.clauses_literals <- 0; + env.learnts_literals <- 0; + env.max_literals <- 0; + env.tot_literals <- 0; + env.nb_init_vars <- 0; + env.nb_init_clauses <- 0; + env.tenv <- empty_theory; + env.model <- Vec.make 0 dummy_var; + env.trail <- Vec.make 601 dummy_atom; + env.trail_lim <- Vec.make 601 (-105); + env.tenv_queue <- Vec.make 100 (empty_theory); + env.tatoms_queue <- Queue.create (); + Solver_types.clear () + + +let copy (v : 'a) : 'a = Marshal.from_string (Marshal.to_string v []) 0 + +let save () = + let sv = + { env = env; + st_cpt_mk_var = !Solver_types.cpt_mk_var; + st_ma = !Solver_types.ma } + in + copy sv + +let restore { env = s_env; st_cpt_mk_var = st_cpt_mk_var; st_ma = st_ma } = + env.is_unsat <- s_env.is_unsat; + env.unsat_core <- s_env.unsat_core; + env.clauses <- s_env.clauses; + env.learnts <- s_env.learnts; + env.clause_inc <- s_env.clause_inc; + env.var_inc <- s_env.var_inc; + env.vars <- s_env.vars; + env.qhead <- s_env.qhead; + env.simpDB_assigns <- s_env.simpDB_assigns; + env.simpDB_props <- s_env.simpDB_props; + env.order <- s_env.order; + env.progress_estimate <- s_env.progress_estimate; + env.restart_first <- s_env.restart_first; + env.starts <- s_env.starts; + env.decisions <- s_env.decisions; + env.propagations <- s_env.propagations; + env.conflicts <- s_env.conflicts; + env.clauses_literals <- s_env.clauses_literals; + env.learnts_literals <- s_env.learnts_literals; + env.max_literals <- s_env.max_literals; + env.tot_literals <- s_env.tot_literals; + env.nb_init_vars <- s_env.nb_init_vars; + env.nb_init_clauses <- s_env.nb_init_clauses; + env.tenv <- s_env.tenv; + env.model <- s_env.model; + env.trail <- s_env.trail; + env.trail_lim <- s_env.trail_lim; + env.tenv_queue <- s_env.tenv_queue; + env.tatoms_queue <- s_env.tatoms_queue; + env.learntsize_factor <- s_env.learntsize_factor; + Solver_types.cpt_mk_var := st_cpt_mk_var; + Solver_types.ma := st_ma + + +end diff --git a/smt/solver.mli b/smt/solver.mli new file mode 100644 index 00000000..6e988d80 --- /dev/null +++ b/smt/solver.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +exception Sat +exception Unsat of Solver_types.clause list + +module Make (Dummy : sig end) : sig + type state + + val solve : unit -> unit + val assume : Literal.LT.t list list -> cnumber : int -> unit + val clear : unit -> unit + + val save : unit -> state + val restore : state -> unit + +end diff --git a/smt/solver_types.ml b/smt/solver_types.ml new file mode 100644 index 00000000..50519bfb --- /dev/null +++ b/smt/solver_types.ml @@ -0,0 +1,273 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format + +let ale = Hstring.make "<=" +let alt = Hstring.make "<" +let agt = Hstring.make ">" + +let is_le n = Hstring.compare n ale = 0 +let is_lt n = Hstring.compare n alt = 0 +let is_gt n = Hstring.compare n agt = 0 + + +type var = + { vid : int; + pa : atom; + na : atom; + mutable weight : float; + mutable seen : bool; + mutable level : int; + mutable reason: reason; + mutable vpremise : premise} + +and atom = + { var : var; + lit : Literal.LT.t; + neg : atom; + mutable watched : clause Vec.t; + mutable is_true : bool; + aid : int } + +and clause = + { name : string; + mutable atoms : atom Vec.t ; + mutable activity : float; + mutable removed : bool; + learnt : bool; + cpremise : premise } + +and reason = clause option + +and premise = clause list + +module Make (Dummy : sig end) = struct + +let dummy_lit = Literal.LT.make (Literal.Eq(Term.vrai,Term.vrai)) + +let rec dummy_var = + { vid = -101; + pa = dummy_atom; + na = dummy_atom; + level = -1; + reason = None; + weight = -1.; + seen = false; + vpremise = [] } +and dummy_atom = + { var = dummy_var; + lit = dummy_lit; + watched = {Vec.dummy=dummy_clause; data=[||]; sz=0}; + neg = dummy_atom; + is_true = false; + aid = -102 } +and dummy_clause = + { name = ""; + atoms = {Vec.dummy=dummy_atom; data=[||]; sz=0}; + activity = -1.; + removed = false; + learnt = false; + cpremise = [] } + + +module MA = Literal.LT.Map + +let ale = Hstring.make "<=" +let alt = Hstring.make "<" +let agt = Hstring.make ">" +let is_le n = Hstring.compare n ale = 0 +let is_lt n = Hstring.compare n alt = 0 +let is_gt n = Hstring.compare n agt = 0 + +let normal_form lit = + match Literal.LT.view lit with + | Literal.Eq (t1,t2) when Term.equal t2 Term.faux -> + Literal.LT.make (Literal.Eq(t1,Term.vrai)), true + + | Literal.Eq (t1,t2) when Term.equal t1 Term.faux -> + Literal.LT.make (Literal.Eq(t2,Term.vrai)), true + + + | Literal.Distinct(false, [t1;t2]) when Term.equal t1 Term.faux -> + Literal.LT.make (Literal.Eq(t2,Term.vrai)), false + + | Literal.Distinct(false, [t1;t2]) when Term.equal t2 Term.faux -> + Literal.LT.make (Literal.Eq(t1,Term.vrai)), false + + | Literal.Distinct(false, [t1;t2]) when Term.equal t1 Term.vrai -> + Literal.LT.make (Literal.Eq(t2,Term.vrai)), true + + | Literal.Distinct(false, [t1;t2]) when Term.equal t2 Term.vrai -> + Literal.LT.make (Literal.Eq(t1,Term.vrai)), true + + | Literal.Distinct(false,[_;_]) -> Literal.LT.neg lit, true + + | Literal.Builtin(true,n,[t1;t2]) when is_gt n -> + Literal.LT.neg lit, true + + | Literal.Builtin(false,n,[t1;t2]) when is_le n -> + Literal.LT.neg lit, true + | _ -> lit, false + + +(* let normal_form lit = *) +(* match Literal.LT.view lit with *) +(* | Literal.Eq (t1,t2) -> *) +(* if Term.equal t2 Term.faux || Term.equal t1 Term.faux then *) +(* Literal.LT.neg lit, true *) +(* else *) +(* lit, false *) + +(* | Literal.Distinct(false,[_;_]) -> Literal.LT.neg lit, true *) +(* | Literal.Builtin(true,n,[t1;t2]) when Builtin.is_gt n -> *) +(* Literal.LT.neg lit, true *) + +(* | Literal.Builtin(false,n,[t1;t2]) when Builtin.is_le n -> *) +(* Literal.LT.neg lit, true *) +(* | _ -> lit, false *) + + +let cpt_mk_var = ref 0 +let ma = ref MA.empty +let make_var = + fun lit -> + let lit, negated = normal_form lit in + try MA.find lit !ma, negated + with Not_found -> + let cpt_fois_2 = !cpt_mk_var lsl 1 in + let rec var = + { vid = !cpt_mk_var; + pa = pa; + na = na; + level = -1; + reason = None; + weight = 0.; + seen = false; + vpremise = []; + } + and pa = + { var = var; + lit = lit; + watched = Vec.make 10 dummy_clause; + neg = na; + is_true = false; + aid = cpt_fois_2 (* aid = vid*2 *) } + and na = + { var = var; + lit = Literal.LT.neg lit; + watched = Vec.make 10 dummy_clause; + neg = pa; + is_true = false; + aid = cpt_fois_2 + 1 (* aid = vid*2+1 *) } in + ma := MA.add lit var !ma; + incr cpt_mk_var; + var, negated + +let made_vars_info () = !cpt_mk_var, MA.fold (fun lit var acc -> var::acc)!ma [] + +let add_atom lit = + let var, negated = make_var lit in + if negated then var.na else var.pa + +let make_clause name ali sz_ali is_learnt premise = + let atoms = Vec.from_list ali sz_ali dummy_atom in + { name = name; + atoms = atoms; + removed = false; + learnt = is_learnt; + activity = 0.; + cpremise = premise} + +let fresh_lname = + let cpt = ref 0 in + fun () -> incr cpt; "L" ^ (string_of_int !cpt) + +let fresh_dname = + let cpt = ref 0 in + fun () -> incr cpt; "D" ^ (string_of_int !cpt) + +let fresh_name = + let cpt = ref 0 in + fun () -> incr cpt; "C" ^ (string_of_int !cpt) + + + +module Clause = struct + + let size c = Vec.size c.atoms + let pop c = Vec.pop c.atoms + let shrink c i = Vec.shrink c.atoms i + let last c = Vec.last c.atoms + let get c i = Vec.get c.atoms i + let set c i v = Vec.set c.atoms i v + +end + +let to_float i = float_of_int i + +let to_int f = int_of_float f + +let clear () = + cpt_mk_var := 0; + ma := MA.empty + +end + + + +module Debug = struct + + let sign a = if a==a.var.pa then "" else "-" + + let level a = + match a.var.level, a.var.reason with + | n, _ when n < 0 -> assert false + | 0, Some c -> sprintf "->0/%s" c.name + | 0, None -> "@0" + | n, Some c -> sprintf "->%d/%s" n c.name + | n, None -> sprintf "@@%d" n + + let value a = + if a.is_true then sprintf "[T%s]" (level a) + else if a.neg.is_true then sprintf "[F%s]" (level a) + else "" + + let value_ms_like a = + if a.is_true then sprintf ":1%s" (level a) + else if a.neg.is_true then sprintf ":0%s" (level a) + else ":X" + + let premise fmt v = + List.iter (fun {name=name} -> fprintf fmt "%s," name) v + + let atom fmt a = + fprintf fmt "%s%d%s [lit:%a] vpremise={{%a}}" + (sign a) (a.var.vid+1) (value a) Literal.LT.print a.lit + premise a.var.vpremise + + + let atoms_list fmt l = List.iter (fprintf fmt "%a ; " atom) l + let atoms_array fmt arr = Array.iter (fprintf fmt "%a ; " atom) arr + + let atoms_vec fmt vec = + for i = 0 to Vec.size vec - 1 do + fprintf fmt "%a ; " atom (Vec.get vec i) + done + + let clause fmt {name=name; atoms=arr; cpremise=cp} = + fprintf fmt "%s:{ %a} cpremise={{%a}}" name atoms_vec arr premise cp + + + +end diff --git a/smt/solver_types.mli b/smt/solver_types.mli new file mode 100644 index 00000000..b951c2b7 --- /dev/null +++ b/smt/solver_types.mli @@ -0,0 +1,81 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + + + +type var = + { vid : int; + pa : atom; + na : atom; + mutable weight : float; + mutable seen : bool; + mutable level : int; + mutable reason : reason; + mutable vpremise : premise } + +and atom = + { var : var; + lit : Literal.LT.t; + neg : atom; + mutable watched : clause Vec.t; + mutable is_true : bool; + aid : int } + +and clause = + { name : string; + mutable atoms : atom Vec.t; + mutable activity : float; + mutable removed : bool; + learnt : bool; + cpremise : premise } + +and reason = clause option + +and premise = clause list + +module Make (Dummy : sig end) : sig + +val cpt_mk_var : int ref +val ma : var Literal.LT.Map.t ref + +val dummy_var : var +val dummy_atom : atom +val dummy_clause : clause + +val make_var : Literal.LT.t -> var * bool + +val add_atom : Literal.LT.t -> atom + +val make_clause : string -> atom list -> int -> bool -> premise-> clause + +val fresh_name : unit -> string + +val fresh_lname : unit -> string + +val fresh_dname : unit -> string + +val to_float : int -> float + +val to_int : float -> int +val made_vars_info : unit -> int * var list +val clear : unit -> unit + +end + +module Debug: sig + + val atom : Format.formatter -> atom -> unit + + val clause : Format.formatter -> clause -> unit + +end diff --git a/smt/sum.ml b/smt/sum.ml new file mode 100644 index 00000000..d9aea3c7 --- /dev/null +++ b/smt/sum.ml @@ -0,0 +1,240 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Alain Mebsout *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format +open Sig +open Exception +module Sy = Symbols +module T = Term +module A = Literal +module L = List +module Hs = Hstring +module Ex = Explanation + +type 'a abstract = Cons of Hs.t * Ty.t | Alien of 'a + +module type ALIEN = sig + include Sig.X + val embed : r abstract -> r + val extract : r -> (r abstract) option +end + +module Make(X : ALIEN) = struct + + type t = X.r abstract + type r = X.r + + let name = "Sum" + + let unsolvable _ = false + + let is_mine_a _ = false + + let is_mine_symb = function + | Sy.Name(_, Sy.Constructor) -> true + | _ -> false + + let fully_interpreted sb = true + + let type_info = function + | Cons (_, ty) -> ty + | Alien x -> X.type_info x + + let is_mine_type c = match type_info c with + | Ty.Tsum _ -> true + | _ -> false + + let color _ = assert false + + let print fmt = function + | Cons (hs,ty) -> fprintf fmt "%s" (Hs.view hs) + | Alien x -> fprintf fmt "%a" X.print x + + let embed r = + match X.extract r with + | Some c -> c + | None -> Alien r + + let is_mine = function + | Alien r -> r + | Cons(hs,ty) as c -> X.embed c + + let compare c1 c2 = + match c1 , c2 with + | Cons (h1,ty1) , Cons (h2,ty2) -> + let n = Hs.compare h1 h2 in + if n <> 0 then n else Ty.compare ty1 ty2 + | Alien r1, Alien r2 -> X.compare r1 r2 + | Alien _ , Cons _ -> 1 + | Cons _ , Alien _ -> -1 + + let hash = function + | Cons (h, ty) -> Hstring.hash h + 19 * Ty.hash ty + | Alien r -> X.hash r + + let leaves _ = [] + + let subst p v c = + let cr = is_mine c in + if X.equal p cr then v + else + match c with + | Cons(hs,t) -> cr + | Alien r -> X.subst p v r + + let make t = match T.view t with + | {T.f=Sy.Name(hs, Sy.Constructor); xs=[];ty=ty} -> + is_mine (Cons(hs,ty)), [] + | _ -> assert false + + let solve a b = + match embed a, embed b with + | Cons(c1,_) , Cons(c2,_) when Hs.equal c1 c2 -> [] + | Cons(c1,_) , Cons(c2,_) -> raise Unsolvable + | Cons _ , Alien r2 -> [r2,a] + | Alien r1 , Cons _ -> [r1,b] + | Alien _ , Alien _ -> assert false + + let term_extract _ = None + + module Rel = struct + type r = X.r + + exception Not_Cons + + module Ex = Explanation + + module MX = Map.Make(struct type t = X.r include X end) + module HSS = Set.Make (struct type t=Hs.t let compare = Hs.compare end) + + type t = (HSS.t * Ex.t) MX.t + + let empty () = MX.empty + + module Debug = struct + + let assume bol r1 r2 = () + + let print_env env = () + + end + + let values_of r = match X.type_info r with + | Ty.Tsum (_,l) -> + Some (List.fold_left (fun st hs -> HSS.add hs st) HSS.empty l) + | _ -> None + + let add_diseq hss sm1 sm2 dep env eqs = + match sm1, sm2 with + | Alien r , Cons(h,ty) + | Cons (h,ty), Alien r -> + let enum, ex = try MX.find r env with Not_found -> hss, Ex.empty in + let enum = HSS.remove h enum in + let ex = Ex.union ex dep in + if HSS.is_empty enum then raise (Inconsistent ex) + else + let env = MX.add r (enum, ex) env in + if HSS.cardinal enum = 1 then + let h' = HSS.choose enum in + env, (LSem (A.Eq(r, is_mine (Cons(h',ty)))), ex)::eqs + else env, eqs + + | Alien r1 , Alien r2 -> env, eqs + | _ -> env, eqs + + let add_eq hss sm1 sm2 dep env eqs = + match sm1, sm2 with + | Alien r, Cons(h,ty) | Cons (h,ty), Alien r -> + + let enum, ex = try MX.find r env with Not_found -> hss, Ex.empty in + let ex = Ex.union ex dep in + if not (HSS.mem h enum) then raise (Inconsistent ex); + MX.add r (HSS.singleton h, ex) env, eqs + + | Alien r1, Alien r2 -> + + let enum1,ex1 = try MX.find r1 env with Not_found -> hss, Ex.empty in + let enum2,ex2 = try MX.find r2 env with Not_found -> hss, Ex.empty in + let ex = Ex.union dep (Ex.union ex1 ex2) in + let diff = HSS.inter enum1 enum2 in + if HSS.is_empty diff then raise (Inconsistent ex); + let env = MX.add r1 (diff, ex) env in + let env = MX.add r2 (diff, ex) env in + if HSS.cardinal diff = 1 then + let h' = HSS.choose diff in + let ty = X.type_info r1 in + env, (LSem (A.Eq(r1, is_mine (Cons(h',ty)))), ex)::eqs + else env, eqs + + | _ -> env, eqs + + let assume env la = + let aux bol r1 r2 dep env eqs = function + | None -> env, eqs + | Some hss -> + Debug.assume bol r1 r2; + if bol then + add_eq hss (embed r1) (embed r2) dep env eqs + else + add_diseq hss (embed r1) (embed r2) dep env eqs + in + Debug.print_env env; + let env, eqs = + List.fold_left + (fun (env,eqs) -> function + | A.Eq(r1,r2), _, ex -> + aux true r1 r2 ex env eqs (values_of r1) + + | A.Distinct(false, [r1;r2]), _, ex -> + aux false r1 r2 ex env eqs (values_of r1) + + | _ -> env, eqs + + ) (env,[]) la + in + env, { assume = eqs; remove = [] } + + (* XXXXXX : TODO -> ajouter les explications dans les choix du + case split *) + + let case_split env = + let acc = MX.fold + (fun r (hss, ex) acc -> + let sz = HSS.cardinal hss in + if sz = 1 then acc + else match acc with + | Some (n,r,hs) when n <= sz -> acc + | _ -> Some (sz, r, HSS.choose hss) + ) env None + in + match acc with + | Some (n,r,hs) -> + let r' = is_mine (Cons(hs,X.type_info r)) in + [A.Eq(r, r'), Ex.empty, Num.Int n] + | None -> [] + + + let query env a_ex = + try ignore(assume env [a_ex]); Sig.No + with Inconsistent expl -> Sig.Yes expl + + let add env r = match embed r, values_of r with + | Alien r, Some hss -> + if MX.mem r env then env else + MX.add r (hss, Ex.empty) env + + | _ -> env + + end +end diff --git a/smt/sum.mli b/smt/sum.mli new file mode 100644 index 00000000..113fc10d --- /dev/null +++ b/smt/sum.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Alain Mebsout *) +(* Mohamed Iguernelala *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type 'a abstract + +module type ALIEN = sig + include Sig.X + val embed : r abstract -> r + val extract : r -> (r abstract) option +end + +module Make + (X : ALIEN) : Sig.THEORY with type r = X.r and type t = X.r abstract + diff --git a/smt/symbols.ml b/smt/symbols.ml new file mode 100644 index 00000000..bf627e23 --- /dev/null +++ b/smt/symbols.ml @@ -0,0 +1,91 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Hashcons + +type operator = + | Plus | Minus | Mult | Div | Modulo + +type name_kind = Ac | Constructor | Other + +type t = + | True + | False + | Name of Hstring.t * name_kind + | Int of Hstring.t + | Real of Hstring.t + | Op of operator + | Var of Hstring.t + +let name ?(kind=Other) s = Name (s, kind) +let var s = Var (Hstring.make s) +let int i = Int (Hstring.make i) +let real r = Real (Hstring.make r) + + +let is_ac = function + | Name(_, Ac) -> true + | _ -> false + +let compare_kind k1 k2 = match k1, k2 with + | Ac , Ac -> 0 + | Ac , _ -> 1 + | _ , Ac -> -1 + | Other, Other -> 0 + | Other, _ -> 1 + | _ , Other -> -1 + | Constructor, Constructor -> 0 + +let compare s1 s2 = match s1, s2 with + | Name (n1,k1), Name (n2,k2) -> + let c = compare_kind k1 k2 in + if c = 0 then Hstring.compare n1 n2 else c + | Name _, _ -> -1 + | _, Name _ -> 1 + | Var n1, Var n2 -> Hstring.compare n1 n2 + | Var _, _ -> -1 + | _ ,Var _ -> 1 + | Int i1, Int i2 -> Hstring.compare i1 i2 + | Int _, _ -> -1 + | _ ,Int _ -> 1 + | _ -> Pervasives.compare s1 s2 + +let equal s1 s2 = compare s1 s2 = 0 + +let hash = function + | Name (n,Ac) -> Hstring.hash n * 19 + 1 + | Name (n,_) -> Hstring.hash n * 19 + | Var n (*| Int n*) -> Hstring.hash n * 19 + 1 + | s -> Hashtbl.hash s + +let to_string = function + | Name (n,_) -> Hstring.view n + | Var x -> "*var* "^(Hstring.view x) + | Int n -> Hstring.view n + | Real n -> Hstring.view n + | Op Plus -> "+" + | Op Minus -> "-" + | Op Mult -> "*" + | Op Div -> "/" + | Op Modulo -> "%" + | True -> "true" + | False -> "false" + +let print fmt s = Format.fprintf fmt "%s" (to_string s) + +module Map = + Map.Make(struct type t' = t type t=t' let compare=compare end) + +module Set = + Set.Make(struct type t' = t type t=t' let compare=compare end) + diff --git a/smt/symbols.mli b/smt/symbols.mli new file mode 100644 index 00000000..68727798 --- /dev/null +++ b/smt/symbols.mli @@ -0,0 +1,43 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type operator = + | Plus | Minus | Mult | Div | Modulo + +type name_kind = Ac | Constructor | Other + +type t = + | True + | False + | Name of Hstring.t * name_kind + | Int of Hstring.t + | Real of Hstring.t + | Op of operator + | Var of Hstring.t + +val name : ?kind:name_kind -> Hstring.t -> t +val var : string -> t +val int : string -> t +val real : string -> t + +val is_ac : t -> bool + +val equal : t -> t -> bool +val compare : t -> t -> int +val hash : t -> int + +val print : Format.formatter -> t -> unit + +module Map : Map.S with type key = t +module Set : Set.S with type elt = t + diff --git a/smt/term.ml b/smt/term.ml new file mode 100644 index 00000000..7cf31329 --- /dev/null +++ b/smt/term.ml @@ -0,0 +1,82 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format +open Hashcons + +module Sy = Symbols + +type view = {f: Sy.t ; xs: t list; ty: Ty.t; tag: int} +and t = view + +module H = struct + type t = view + let equal t1 t2 = try + Sy.equal t1.f t2.f + && List.for_all2 (==) t1.xs t2.xs + && Ty.equal t1.ty t2.ty + with Invalid_argument _ -> false + + let hash t = + abs (List.fold_left + (fun acc x-> acc*19 +x.tag) (Sy.hash t.f + Ty.hash t.ty) + t.xs) + let tag tag x = {x with tag = tag} +end + +module T = Make(H) + +let view t = t + +let rec print fmt t = + let {f=x; xs=l; ty=ty} = view t in + match x, l with + | Sy.Op op, [e1; e2] -> + fprintf fmt "(%a %a %a)" print e1 Sy.print x print e2 + | _, [] -> fprintf fmt "%a" Sy.print x + | _, _ -> fprintf fmt "%a(%a)" Sy.print x print_list l + +and print_list fmt = function + | [] -> () + | [t] -> print fmt t + | t::l -> Format.fprintf fmt "%a,%a" print t print_list l + +let compare t1 t2 = + let c = Pervasives.compare t2.tag t1.tag in + if c = 0 then c else + match (view t1).f, (view t2).f with + | (Sy.True | Sy.False ), (Sy.True | Sy.False ) -> c + | (Sy.True | Sy.False ), _ -> -1 + | _, (Sy.True | Sy.False ) -> 1 + | _,_ -> c + +let make s l ty = T.hashcons {f=s;xs=l;ty=ty;tag=0 (* dumb_value *) } + +let vrai = make (Sy.True) [] Ty.Tbool +let faux = make (Sy.False) [] Ty.Tbool + +let int i = make (Sy.int i) [] Ty.Tint +let real r = make (Sy.real r) [] Ty.Treal + +let is_int t = (view t).ty= Ty.Tint +let is_real t = (view t).ty= Ty.Treal + +let equal t1 t2 = t1 == t2 + +let hash t = t.tag + +module Set = + Set.Make(struct type t' = t type t=t' let compare=compare end) + +module Map = + Map.Make(struct type t' = t type t=t' let compare=compare end) diff --git a/smt/term.mli b/smt/term.mli new file mode 100644 index 00000000..0274e347 --- /dev/null +++ b/smt/term.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type t +type view = private {f: Symbols.t ; xs: t list; ty: Ty.t; tag : int} + +val view : t -> view +val make : Symbols.t -> t list -> Ty.t -> t + +val vrai : t +val faux : t +val int : string -> t +val real : string -> t + +val is_int : t -> bool +val is_real : t -> bool + +val compare : t -> t -> int +val equal : t -> t -> bool +val hash : t -> int + +val print : Format.formatter -> t -> unit + +module Map : Map.S with type key = t +module Set : Set.S with type elt = t + diff --git a/smt/ty.ml b/smt/ty.ml new file mode 100644 index 00000000..1375f1c7 --- /dev/null +++ b/smt/ty.ml @@ -0,0 +1,58 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format + +type t = + | Tint + | Treal + | Tbool + | Tabstract of Hstring.t + | Tsum of Hstring.t * Hstring.t list + +let hash t = + match t with + | Tabstract s -> Hstring.hash s + | Tsum (s, l) -> + let h = + List.fold_left + (fun h x -> 13 * h + Hstring.hash x) (Hstring.hash s) l + in + abs h + | _ -> Hashtbl.hash t + +let equal t1 t2 = + match t1, t2 with + | Tabstract s1, Tabstract s2 + | Tsum (s1, _), Tsum (s2, _) -> + Hstring.equal s1 s2 + | Tint, Tint | Treal, Treal | Tbool, Tbool -> true + | _ -> false + +let compare t1 t2 = + match t1, t2 with + | Tabstract s1, Tabstract s2 -> + Hstring.compare s1 s2 + | Tabstract _, _ -> -1 | _ , Tabstract _ -> 1 + | Tsum (s1, _), Tsum(s2, _) -> + Hstring.compare s1 s2 + | Tsum _, _ -> -1 | _ , Tsum _ -> 1 + | t1, t2 -> Pervasives.compare t1 t2 + +let print fmt ty = + match ty with + | Tint -> fprintf fmt "int" + | Treal -> fprintf fmt "real" + | Tbool -> fprintf fmt "bool" + | Tabstract s -> fprintf fmt "%s" (Hstring.view s) + | Tsum (s, _) -> fprintf fmt "%s" (Hstring.view s) diff --git a/smt/ty.mli b/smt/ty.mli new file mode 100644 index 00000000..d42e3feb --- /dev/null +++ b/smt/ty.mli @@ -0,0 +1,24 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon and Alain Mebsout *) +(* Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +type t = + | Tint + | Treal + | Tbool + | Tabstract of Hstring.t + | Tsum of Hstring.t * Hstring.t list + +val hash : t -> int +val equal : t -> t -> bool +val compare : t -> t -> int +val print : Format.formatter -> t -> unit diff --git a/smt/uf.ml b/smt/uf.ml new file mode 100644 index 00000000..41591f59 --- /dev/null +++ b/smt/uf.ml @@ -0,0 +1,359 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Evelyne Contejean *) +(* Francois Bobot, Mohamed Iguernelala, Alain Mebsout *) +(* CNRS, Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +open Format +open Exception +open Sig + +module type S = sig + type t + + module R : Sig.X + + val empty : t + val add : t -> Term.t -> t * Literal.LT.t list + + val mem : t -> Term.t -> bool + + val find : t -> Term.t -> R.r * Explanation.t + val find_r : t -> R.r -> R.r * Explanation.t + + val union : + t -> R.r -> R.r -> Explanation.t -> + t * (R.r * (R.r * R.r * Explanation.t) list * R.r) list + + val distinct : t -> R.r list -> Explanation.t -> t + + val are_equal : t -> Term.t -> Term.t -> Sig.answer + val are_distinct : t -> Term.t -> Term.t -> Sig.answer + val already_distinct : t -> R.r list -> bool + + val class_of : t -> Term.t -> Term.t list +end + +module Make ( R : Sig.X ) = struct + + module L = List + module HS = Hstring + module Ex = Explanation + module R = R + module Sy = Symbols + module T = Term + module MapT = Term.Map + module SetT = Term.Set + + module Lit = Literal.Make(struct type t = R.r include R end) + module MapL = Lit.Map + + module MapR = Map.Make(struct type t = R.r let compare = R.compare end) + + module SetR = Set.Make(struct type t = R.r let compare = R.compare end) + + module SetRR = Set.Make(struct + type t = R.r * R.r + let compare (r1, r1') (r2, r2') = + let c = R.compare r1 r2 in + if c <> 0 then c + else R.compare r1' r2' + end) + + + type t = { + + (* term -> [t] *) + make : R.r MapT.t; + + (* representative table *) + repr : (R.r * Ex.t) MapR.t; + + (* r -> class (of terms) *) + classes : SetT.t MapR.t; + + (*associates each value r with the set of semantical values whose + representatives contains r *) + gamma : SetR.t MapR.t; + + (* the disequations map *) + neqs: Ex.t MapL.t MapR.t; + + } + + let empty = { + make = MapT.empty; + repr = MapR.empty; + classes = MapR.empty; + gamma = MapR.empty; + neqs = MapR.empty; + } + + module Env = struct + + let mem env t = MapT.mem t env.make + + let lookup_by_t t env = + try MapR.find (MapT.find t env.make) env.repr + with Not_found -> + assert false (*R.make t, Ex.empty*) (* XXXX *) + + let lookup_by_r r env = + try MapR.find r env.repr with Not_found -> r, Ex.empty + + let lookup_for_neqs env r = + try MapR.find r env.neqs with Not_found -> MapL.empty + + let add_to_classes t r classes = + MapR.add r + (SetT.add t (try MapR.find r classes with Not_found -> SetT.empty)) + classes + + let update_classes c nc classes = + let s1 = try MapR.find c classes with Not_found -> SetT.empty in + let s2 = try MapR.find nc classes with Not_found -> SetT.empty in + MapR.remove c (MapR.add nc (SetT.union s1 s2) classes) + + let add_to_gamma r c gamma = + L.fold_left + (fun gamma x -> + let s = try MapR.find x gamma with Not_found -> SetR.empty in + MapR.add x (SetR.add r s) gamma) gamma (R.leaves c) + + (* r1 = r2 => neqs(r1) \uplus neqs(r2) *) + let update_neqs r1 r2 dep env = + let nq_r1 = lookup_for_neqs env r1 in + let nq_r2 = lookup_for_neqs env r2 in + let mapl = + MapL.fold + (fun l1 ex1 mapl -> + try + let ex2 = MapL.find l1 mapl in + let ex = Ex.union (Ex.union ex1 ex2) dep in (* VERIF *) + raise (Inconsistent ex) + with Not_found -> + MapL.add l1 (Ex.union ex1 dep) mapl) + nq_r1 nq_r2 + in + MapR.add r2 mapl (MapR.add r1 mapl env.neqs) + + let filter_leaves r = + L.fold_left (fun p r -> SetR.add r p) SetR.empty (R.leaves r) + + let canon_empty st env = + SetR.fold + (fun p ((z, ex) as acc) -> + let q, ex_q = lookup_by_r p env in + if R.equal p q then acc else (p,q)::z, Ex.union ex_q ex) + st ([], Ex.empty) + + let canon_aux rx = List.fold_left (fun r (p,v) -> R.subst p v r) rx + + let rec canon env r ex_r = + let se = filter_leaves r in + let subst, ex_subst = canon_empty se env in + let r2 = canon_aux r subst in + let ex_r2 = Ex.union ex_r ex_subst in + if R.equal r r2 then r2, ex_r2 else canon env r2 ex_r2 + + let normal_form env r = canon env r Ex.empty + + let find_or_normal_form env r = + try MapR.find r env.repr with Not_found -> normal_form env r + + let init_leaf env p = + let in_repr = MapR.mem p env.repr in + let in_neqs = MapR.mem p env.neqs in + { env with + repr = + if in_repr then env.repr + else MapR.add p (p, Ex.empty) env.repr; + classes = + if in_repr then env.classes + else update_classes p p env.classes; + gamma = + if in_repr then env.gamma + else add_to_gamma p p env.gamma ; + neqs = + if in_neqs then env.neqs + else update_neqs p p Ex.empty env } + + let init_term env t = + let mkr, ctx = R.make t in + let rp, ex = normal_form env mkr in + { make = MapT.add t mkr env.make; + repr = MapR.add mkr (rp,ex) env.repr; + classes = add_to_classes t rp env.classes; + gamma = add_to_gamma mkr rp env.gamma; + neqs = + if MapR.mem rp env.neqs then env.neqs (* pourquoi ce test *) + else MapR.add rp MapL.empty env.neqs}, ctx + + + let update_aux dep set env= + SetRR.fold + (fun (rr, nrr) env -> + { env with + neqs = update_neqs rr nrr dep env ; + classes = update_classes rr nrr env.classes}) + set env + + let apply_sigma_uf env (p, v, dep) = + assert (MapR.mem p env.gamma); + let use_p = MapR.find p env.gamma in + try + let env, tch, neqs_to_up = SetR.fold + (fun r (env, touched, neqs_to_up) -> + let rr, ex = MapR.find r env.repr in + let nrr = R.subst p v rr in + if R.equal rr nrr then env, touched, neqs_to_up + else + let ex = Ex.union ex dep in + let env = + {env with + repr = MapR.add r (nrr, ex) env.repr; + gamma = add_to_gamma r nrr env.gamma } + in + env, (r, nrr, ex)::touched, SetRR.add (rr, nrr) neqs_to_up + ) use_p (env, [], SetRR.empty) in + (* Correction : Do not update neqs twice for the same r *) + update_aux dep neqs_to_up env, tch + + with Not_found -> assert false + + let apply_sigma eqs env tch ((p, v, dep) as sigma) = + let env = init_leaf env p in + let env, touched = apply_sigma_uf env sigma in + env, ((p, touched, v) :: tch) + + end + + let add env t = + if MapT.mem t env.make then env, [] else Env.init_term env t + + let ac_solve eqs dep (env, tch) (p, v) = + (* pourquoi recuperer le representant de rv? r = rv d'apres testopt *) + (* assert ( let rp, _ = Env.find_or_normal_form env p in R.equal p rp); *) + let rv, ex_rv = Env.find_or_normal_form env v in + (* let rv = v in *) + (* assert ( let rv, _ = Env.find_or_normal_form env v in R.equal v rv); *) + let dep = Ex.union ex_rv dep in + Env.apply_sigma eqs env tch (p, rv, dep) + + let x_solve env r1 r2 dep = + let rr1, ex_r1 = Env.find_or_normal_form env r1 in + let rr2, ex_r2 = Env.find_or_normal_form env r2 in + let dep = Ex.union dep (Ex.union ex_r1 ex_r2) in + if R.equal rr1 rr2 then begin + [] (* Remove rule *) + end + else + begin + ignore (Env.update_neqs rr1 rr2 dep env); + try R.solve rr1 rr2 + with Unsolvable -> + raise (Inconsistent dep) + end + + let rec ac_x eqs env tch = + if Queue.is_empty eqs then env, tch + else + let r1, r2, dep = Queue.pop eqs in + let sbs = x_solve env r1 r2 dep in + let env, tch = List.fold_left (ac_solve eqs dep) (env, tch) sbs in + ac_x eqs env tch + + let union env r1 r2 dep = + let equations = Queue.create () in + Queue.push (r1,r2, dep) equations; + ac_x equations env [] + + let rec distinct env rl dep = + let d = Lit.make (Literal.Distinct (false,rl)) in + let env, _, newds = + List.fold_left + (fun (env, mapr, newds) r -> + let rr, ex = Env.find_or_normal_form env r in + try + let exr = MapR.find rr mapr in + raise (Inconsistent (Ex.union ex exr)) + with Not_found -> + let uex = Ex.union ex dep in + let mdis = + try MapR.find rr env.neqs with Not_found -> MapL.empty in + let mdis = + try + MapL.add d (Ex.merge uex (MapL.find d mdis)) mdis + with Not_found -> + MapL.add d uex mdis + in + let env = Env.init_leaf env rr in + let env = {env with neqs = MapR.add rr mdis env.neqs} in + env, MapR.add rr uex mapr, (rr, ex, mapr)::newds + ) + (env, MapR.empty, []) + rl + in + List.fold_left + (fun env (r1, ex1, mapr) -> + MapR.fold (fun r2 ex2 env -> + let ex = Ex.union ex1 (Ex.union ex2 dep) in + try match R.solve r1 r2 with + | [a, b] -> + if (R.equal a r1 && R.equal b r2) || + (R.equal a r2 && R.equal b r1) then env + else + distinct env [a; b] ex + | [] -> + raise (Inconsistent ex) + | _ -> env + with Unsolvable -> env) mapr env) + env newds + + + let are_equal env t1 t2 = + let r1, ex_r1 = Env.lookup_by_t t1 env in + let r2, ex_r2 = Env.lookup_by_t t2 env in + if R.equal r1 r2 then Yes(Ex.union ex_r1 ex_r2) else No + + let are_distinct env t1 t2 = + let r1, ex_r1 = Env.lookup_by_t t1 env in + let r2, ex_r2 = Env.lookup_by_t t2 env in + try + ignore (union env r1 r2 (Ex.union ex_r1 ex_r2)); + No + with Inconsistent ex -> Yes(ex) + + let already_distinct env lr = + let d = Lit.make (Literal.Distinct (false,lr)) in + try + List.iter (fun r -> + let mdis = MapR.find r env.neqs in + ignore (MapL.find d mdis) + ) lr; + true + with Not_found -> false + + let find env t = + Env.lookup_by_t t env + + let find_r = Env.find_or_normal_form + + let mem = Env.mem + + let class_of env t = + try + let rt, _ = MapR.find (MapT.find t env.make) env.repr in + SetT.elements (MapR.find rt env.classes) + with Not_found -> [t] + + +end diff --git a/smt/uf.mli b/smt/uf.mli new file mode 100644 index 00000000..0106d5ce --- /dev/null +++ b/smt/uf.mli @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Evelyne Contejean *) +(* Francois Bobot, Mohamed Iguernelala, Alain Mebsout *) +(* CNRS, Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module type S = sig + type t + + module R : Sig.X + + val empty : t + val add : t -> Term.t -> t * Literal.LT.t list + + val mem : t -> Term.t -> bool + + val find : t -> Term.t -> R.r * Explanation.t + + val find_r : t -> R.r -> R.r * Explanation.t + + val union : + t -> R.r -> R.r -> Explanation.t -> + t * (R.r * (R.r * R.r * Explanation.t) list * R.r) list + + val distinct : t -> R.r list -> Explanation.t -> t + + val are_equal : t -> Term.t -> Term.t -> Sig.answer + val are_distinct : t -> Term.t -> Term.t -> Sig.answer + val already_distinct : t -> R.r list -> bool + + val class_of : t -> Term.t -> Term.t list +end + +module Make ( X : Sig.X ) : S with module R = X diff --git a/smt/use.ml b/smt/use.ml new file mode 100644 index 00000000..b90a7017 --- /dev/null +++ b/smt/use.ml @@ -0,0 +1,83 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Evelyne Contejean *) +(* Francois Bobot, Mohamed Iguernelala, Alain Mebsout *) +(* CNRS, Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module F = Format +module L = List +module T = Term +module S = Symbols +module ST = T.Set +(* module SA = Literal.LT.Set *) + +module SA = Set.Make(struct + type t = Literal.LT.t * Explanation.t + let compare (s1,_) (s2,_) = Literal.LT.compare s1 s2 +end) + +type elt = ST.t * SA.t + +module Make (X : Sig.X) = struct + + let inter_tpl (x1,y1) (x2,y2) = ST.inter x1 x2, SA.inter y1 y2 + let union_tpl (x1,y1) (x2,y2) = ST.union x1 x2, SA.union y1 y2 + let bottom = Hstring.make "@bottom" + let leaves r = + let one, _ = X.make (T.make (Symbols.name bottom) [] Ty.Tint) in + match X.leaves r with [] -> [one] | l -> l + + module G = Map.Make(struct type t = X.r include X end) + + open G + + type t = elt G.t + + + let find k m = try find k m with Not_found -> (ST.empty,SA.empty) + + let add_term k t mp = + let g_t,g_a = find k mp in add k (ST.add t g_t,g_a) mp + + let up_add g t rt lvs = + let g = if mem rt g then g else add rt (ST.empty, SA.empty) g in + L.fold_left (fun g x -> add_term x t g) g lvs + + let congr_add g lvs = + match lvs with + [] -> ST.empty + | x::ls -> + L.fold_left + (fun acc y -> ST.inter (fst(find y g)) acc) + (fst(find x g)) ls + + let up_close_up g p v = + let lvs = leaves v in + let g_p = find p g in + L.fold_left (fun gg l -> add l (union_tpl g_p (find l g)) gg) g lvs + + let congr_close_up g p touched = + let inter = function + [] -> (ST.empty, SA.empty) + | rx::l -> + L.fold_left (fun acc x ->inter_tpl acc (find x g))(find rx g) l + in + L.fold_left + (fun (st,sa) tch -> union_tpl (st,sa)(inter (leaves tch))) + (find p g) touched + + let print g = () + + let mem = G.mem + let add = G.add + let empty = G.empty + +end diff --git a/smt/use.mli b/smt/use.mli new file mode 100644 index 00000000..9629b540 --- /dev/null +++ b/smt/use.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* Cubicle *) +(* Combining model checking algorithms and SMT solvers *) +(* *) +(* Sylvain Conchon, Evelyne Contejean *) +(* Francois Bobot, Mohamed Iguernelala, Alain Mebsout *) +(* CNRS, Universite Paris-Sud 11 *) +(* *) +(* Copyright 2011. This file is distributed under the terms of the *) +(* Apache Software License version 2.0 *) +(* *) +(**************************************************************************) + +module T : sig type t = Term.t end +module S : sig type t = Symbols.t end +module ST : sig type elt = T.t type t = Term.Set.t end +module SA : Set.S with type elt = Literal.LT.t * Explanation.t + +type elt = ST.t * SA.t + +module Make : + functor (X : Sig.X) -> +sig + + type t + val empty : t + val find : X.r -> t -> elt + val add : X.r -> elt -> t -> t + val mem : X.r -> t -> bool + val print : t -> unit + val up_add : t -> ST.elt -> X.r -> X.r list -> t + + val congr_add : t -> X.r list -> ST.t + + val up_close_up :t -> X.r -> X.r -> t + val congr_close_up : t -> X.r -> X.r list -> elt +end