├── .gitignore ├── lib ├── doc.odocl ├── z3.mllib ├── z3.mldylib ├── Smtlib_syntax.ml ├── Smtlib_syntax.mli ├── META ├── Smtlib_parser.mly ├── Smtlib_lexer.mll ├── Smtlib.mli └── Smtlib.ml ├── opam ├── configure ├── _tags ├── README.md ├── _oasis ├── Makefile └── myocamlbuild.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *.native 2 | _build 3 | /setup.data 4 | /setup.log -------------------------------------------------------------------------------- /lib/doc.odocl: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: fb731314cd9fa9e37bdba78719f8d6fc) 3 | Smtlib 4 | # OASIS_STOP 5 | -------------------------------------------------------------------------------- /lib/z3.mllib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: baecd9d802eeb7381c8285c21d05e655) 3 | Smtlib 4 | Smtlib_syntax 5 | Smtlib_parser 6 | Smtlib_lexer 7 | # OASIS_STOP 8 | -------------------------------------------------------------------------------- /lib/z3.mldylib: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: baecd9d802eeb7381c8285c21d05e655) 3 | Smtlib 4 | Smtlib_syntax 5 | Smtlib_parser 6 | Smtlib_lexer 7 | # OASIS_STOP 8 | -------------------------------------------------------------------------------- /lib/Smtlib_syntax.ml: -------------------------------------------------------------------------------- 1 | type sexp = 2 | | SList of sexp list 3 | | SSymbol of string 4 | | SString of string 5 | | SKeyword of string 6 | | SInt of int 7 | | SBitVec of int * int 8 | | SBitVec64 of int64 9 | -------------------------------------------------------------------------------- /lib/Smtlib_syntax.mli: -------------------------------------------------------------------------------- 1 | type sexp = 2 | | SList of sexp list 3 | | SSymbol of string 4 | | SString of string 5 | | SKeyword of string 6 | | SInt of int 7 | | SBitVec of int * int 8 | | SBitVec64 of int64 9 | -------------------------------------------------------------------------------- /lib/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 13c329d40f685f0b0b25d4b8629e9625) 3 | version = "1.1.0" 4 | description = "Bindings for Z3" 5 | requires = "ppx_deriving.std" 6 | archive(byte) = "z3.cma" 7 | archive(byte, plugin) = "z3.cma" 8 | archive(native) = "z3.cmxa" 9 | archive(native, plugin) = "z3.cmxs" 10 | exists_if = "z3.cma" 11 | # OASIS_STOP 12 | 13 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | ocaml-version: [ >= "4.02.0" ] 3 | version: "1.1.0" 4 | maintainer: "Arjun Guha " 5 | build: [ 6 | ["./configure" "--prefix" prefix ] 7 | [make] 8 | ] 9 | install: [ 10 | [make "install"] 11 | ] 12 | remove: [ 13 | ["ocamlfind" "remove" "z3"] 14 | ] 15 | depends: [ 16 | "ocamlfind" {build} 17 | "oasis" {build & >= "0.4.0"} 18 | "ppx_deriving" {>= "4.2" & < "4.3"} 19 | ] 20 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /lib/Smtlib_parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Smtlib_syntax 3 | %} 4 | 5 | %token LPAREN RPAREN 6 | %token STRING 7 | %token SYMBOL 8 | %token KEYWORD 9 | %token INT 10 | %token HEX 11 | %token EOF 12 | 13 | %start sexp 14 | %type sexp 15 | 16 | %% 17 | 18 | sexp_list : 19 | | { [] } 20 | | sexp sexp_list { $1 :: $2 } 21 | 22 | sexp : 23 | | INT { SInt $1 } 24 | | HEX { let (n, w) = $1 in SBitVec (n, w) } 25 | | STRING { SString $1 } 26 | | SYMBOL { SSymbol $1 } 27 | | KEYWORD { SKeyword $1 } 28 | | LPAREN sexp_list RPAREN { SList $2 } 29 | 30 | %% 31 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 4ea84ba84c73986ec0e7b7f8cd538590) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | true: annot, bin_annot 7 | <**/.svn>: -traverse 8 | <**/.svn>: not_hygienic 9 | ".bzr": -traverse 10 | ".bzr": not_hygienic 11 | ".hg": -traverse 12 | ".hg": not_hygienic 13 | ".git": -traverse 14 | ".git": not_hygienic 15 | "_darcs": -traverse 16 | "_darcs": not_hygienic 17 | # Library z3 18 | "lib/z3.cmxs": use_z3 19 | : package(ppx_deriving.std) 20 | # OASIS_STOP 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ocaml-z3 2 | ============== 3 | 4 | An OCaml interface to the Z3 SMT solver 5 | 6 | Local build steps 7 | --------------------- 8 | 9 | This package depends on the ```oasis``` build system being installed on your machine. 10 | 11 | From the project's root directory: 12 | ``` 13 | ./configure 14 | make build 15 | make install 16 | ``` 17 | 18 | 19 | Installation with OPAM 20 | ---------------------- 21 | 22 | - Install [Git](https://git-scm.com/downloads) 23 | 24 | On Mac OS X, Git is included with [XCode](https://developer.apple.com/xcode/). 25 | 26 | - Install [OPAM](https://opam.ocaml.org/doc/Install.html) 27 | 28 | - From the command line, run: 29 | 30 | ``` 31 | opam pin add z3 https://github.com/plasma-umass/ocaml-z3.git 32 | ``` 33 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | OCamlVersion: >= 4.02.0 3 | Name: ocaml-z3 4 | Version: 1.1.0 5 | Synopsis: Bindings for Z3 6 | Authors: Samuel Baxter, Arjun Guha, Rachit Nigam, Robert Powers 7 | License: LGPL 8 | Plugins: META (0.4), DevFiles (0.4) 9 | BuildTools: ocamlbuild, ocamldoc 10 | AlphaFeatures: ocamlbuild_more_args 11 | XOCamlbuildExtraArgs: -cflags -w,-40,-short-paths 12 | 13 | Library z3 14 | Path: lib 15 | BuildDepends: 16 | ppx_deriving.std 17 | InternalModules: 18 | Smtlib_syntax, 19 | Smtlib_parser, 20 | Smtlib_lexer 21 | Modules: 22 | Smtlib 23 | 24 | Document doc 25 | Title: ocaml-z3 documentation 26 | Type: ocamlbuild (0.4) 27 | XOCamlBuildPath: lib 28 | XOCamlBuildModules: 29 | Smtlib -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /lib/Smtlib_lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Lexing 3 | open Smtlib_parser 4 | 5 | let parse_hex (str : string) : (int * int) = 6 | let len = (String.length str) - 2 in 7 | let str = "0x" ^ (String.sub str 2 len) in 8 | (int_of_string str, len * 4) 9 | let parse_bin (str : string) : (int * int) = 10 | let len = (String.length str) - 2 in 11 | let str = "0b" ^ (String.sub str 2 len) in 12 | (int_of_string str, len ) 13 | } 14 | 15 | let simple_symbol_char = [ 'A'-'Z' 'a'-'z' '+' '-' '/' '|' '*' '=' '%' '?' '!' '.' '$' '_' '~' '&' '^' '<' '>' '@'] 16 | let simple_symbol = simple_symbol_char (['0' - '9'] | simple_symbol_char )* 17 | let keyword = ':' simple_symbol 18 | let blank = [ ' ' '\t' ] 19 | let numeral = (( ['-']?['1'-'9']['0'-'9']* ) | ['0']) 20 | let hex_int = "#x" [ '0'-'9' 'a'-'f' ]+ 21 | let bin_int = "#b" ['0'-'1']+ 22 | let string = ("\\\"" | [^ '"'])* 23 | 24 | rule token = parse 25 | | ";" [^ '\n' '\r']+ { token lexbuf } 26 | | "\r\n" { new_line lexbuf; token lexbuf } 27 | | "\n" { new_line lexbuf; token lexbuf } 28 | | blank+ { token lexbuf } 29 | | eof { EOF } 30 | | numeral as n { INT (int_of_string n) } 31 | | hex_int as str { let (n, w) = parse_hex str in HEX (n, w) } 32 | | bin_int as str { let (n, w) = parse_bin str in HEX (n,w) } 33 | | "(" { LPAREN } 34 | | ")" { RPAREN } 35 | | "\"" (string as x) "\"" { STRING x } 36 | | simple_symbol as x { SYMBOL x } 37 | | keyword as x { KEYWORD x } 38 | 39 | and block_comment = parse 40 | | "*/" { token lexbuf } 41 | | "*" { block_comment lexbuf } 42 | | "\r\n" { new_line lexbuf; block_comment lexbuf } 43 | | "\n" { new_line lexbuf; block_comment lexbuf } 44 | | ([^ '*' '\n'])+ { block_comment lexbuf } 45 | -------------------------------------------------------------------------------- /lib/Smtlib.mli: -------------------------------------------------------------------------------- 1 | (** An OCaml API for working with SMT-LIB-based solvers, such as Z3. *) 2 | 3 | (** {1 Starting solvers.} *) 4 | 5 | (** A handle to a Z3 process. *) 6 | type solver 7 | 8 | (** [make_solver path] produces a handle to a Z3 process. 9 | 10 | The argument [path] must be the path to the Z3 executable. If [z3] is on the 11 | [PATH], this can just be ["z3"]. 12 | 13 | This command starts Z3 with the flags [-in] and [-smt2]. *) 14 | val make_solver : string -> solver 15 | 16 | (** {1 High-level API.} 17 | 18 | This high-level API to Z3 provides simple functions to construct 19 | terms and send commands to Z3. If Z3 produces an error in response to a 20 | command, that error is raised as an OCaml exception. 21 | *) 22 | 23 | type identifier = 24 | | Id of string 25 | 26 | type sort = 27 | | Sort of identifier 28 | | SortApp of identifier * sort list 29 | | BitVecSort of int 30 | 31 | type term = 32 | | String of string 33 | | Int of int 34 | | BitVec of int * int 35 | | BitVec64 of int64 36 | | Const of identifier 37 | | App of identifier * term list 38 | | Let of string * term * term 39 | 40 | (** Tactics to configure z3's solver strategy. *) 41 | type tactic = 42 | | Simplify 43 | | SolveEQs 44 | | BitBlast 45 | | AIG 46 | | SAT 47 | | SMT 48 | | QFBV 49 | (** Tactic combinators *) 50 | | UsingParams of tactic * (string * bool) list 51 | | Then of tactic list 52 | 53 | type check_sat_result = 54 | | Sat 55 | | Unsat 56 | | Unknown 57 | 58 | (** [declare_const solver x sort] runs the command [(declare-const x sort)] *) 59 | val declare_const : solver -> identifier -> sort -> unit 60 | 61 | (** [declare_fun solver x sorts sort] runs the command [(declare-fun x sorts sort)] *) 62 | val declare_fun : solver -> identifier -> sort list -> sort -> unit 63 | 64 | (** [declare_sort solver x arity] runs the command [(declare-sort x arity)] *) 65 | val declare_sort : solver -> identifier -> int -> unit 66 | 67 | (** [assert_ solver term] runs the command [(assert term)] *) 68 | val assert_ : solver -> term -> unit 69 | 70 | (** [assert_soft solver term ?~weight ?~id] runs the command [(assert-soft term :weight ~weight :id ~id] *) 71 | val assert_soft : solver -> ?weight:int -> ?id:string -> term -> unit 72 | 73 | (** [maximize solver e] runs the command [(maximize e)] *) 74 | val maximize : solver -> term -> unit 75 | 76 | (** [minimize solver e] runs the command [(minimize e)] *) 77 | val minimize : solver -> term -> unit 78 | 79 | (** [read_objectives solver] reads output of objective function printed after calls to [check_sat solver] *) 80 | val read_objectives : solver -> unit 81 | 82 | (** [check_sat solver] runs the command [(check-sat)] *) 83 | val check_sat : solver -> check_sat_result 84 | 85 | (** [check_sat using tactic solver] runs the command 86 | [(check-sat-using tactic)] *) 87 | val check_sat_using : tactic -> solver -> check_sat_result 88 | 89 | (** [get_model solver] runs the command [(get-model)] *) 90 | val get_model : solver -> (identifier * term) list 91 | 92 | (** [get_one_value solver e] runs the command [(get-value e)] *) 93 | val get_one_value : solver -> term -> term 94 | 95 | (** [push solver] runs the command [(push)] *) 96 | val push : solver -> unit 97 | 98 | (** [pop solver] runs the command [(pop)] *) 99 | val pop : solver -> unit 100 | 101 | (** The expression [Int] for the solver. *) 102 | val int_sort : sort 103 | 104 | (** The expression [Bool] for the solver. *) 105 | val bool_sort : sort 106 | 107 | (** [array_sort dom range] produces [(array dom range)] *) 108 | val array_sort : sort -> sort -> sort 109 | 110 | val int_to_term : int -> term 111 | 112 | val bool_to_term : bool -> term 113 | 114 | (** [const x] produces [Const (Id x)], which represents a reference to a 115 | variable declared with [(declare-const x sort)] *) 116 | val const : string -> term 117 | 118 | (** [equals e1 e2] produces [(= e1 e2)] *) 119 | val equals : term -> term -> term 120 | 121 | (** [and e1 e2] produces [(and e1 e2)]. In addition, nested [and]s are flattened 122 | to make debugging easier. *) 123 | val and_ : term -> term -> term 124 | 125 | (** [or e1 e2] produces [(or e1 e2)]. In addition, nested [or]s are flattened 126 | to make debugging easier. *) 127 | val or_ : term -> term -> term 128 | 129 | (** [xor e1 e2] produces [(xor e1 e2)]. *) 130 | val xor : term -> term -> term 131 | 132 | (** [not e] produces [(not e)]. *) 133 | val not_ : term -> term 134 | 135 | (** [ite e1 e2 e3] produces [(ite e1 e2 e3)] *) 136 | val ite : term -> term -> term -> term 137 | 138 | (** [implies e1 e2] produces [(=> e1 e2)]. *) 139 | val implies : term -> term -> term 140 | 141 | (** [add e1 e2] produces [(+ e1 e2)]. *) 142 | val add : term -> term -> term 143 | 144 | (** [sub e1 e2] produces [(- e1 e2)]. *) 145 | val sub : term -> term -> term 146 | 147 | (** [mul e1 e2] produces [( * e1 e2)]. *) 148 | val mul : term -> term -> term 149 | 150 | (** [lt e1 e2] produces [(< e1 e2)]. *) 151 | val lt : term -> term -> term 152 | 153 | (** [> e1 e2] produces [(> e1 e2)]. *) 154 | val gt : term -> term -> term 155 | 156 | (** [lte e1 e2] produces [(<= e1 e2)]. *) 157 | val lte : term -> term -> term 158 | 159 | (** [gte e1 e2] produces [(>= e1 e2)]. *) 160 | val gte : term -> term -> term 161 | 162 | (** {1 Bit-Vectors} *) 163 | 164 | (** [bv_sort n] produces [(_ BitVec n)]. *) 165 | val bv_sort : int -> sort 166 | 167 | (** [bv n w] produces a bit-vector of width [w] that represents the integer [n]. *) 168 | val bv : int -> int -> term 169 | 170 | (** [bv64 n] produces a bit-vector of width [w] that represents the 64-bit integer [n]. *) 171 | val bv64 : int64 -> term 172 | 173 | val bvadd : term -> term -> term 174 | val bvsub : term -> term -> term 175 | val bvmul : term -> term -> term 176 | val bvurem : term -> term -> term 177 | val bvsrem : term -> term -> term 178 | val bvsmod : term -> term -> term 179 | val bvshl : term -> term -> term 180 | val bvlshr : term -> term -> term 181 | val bvashr : term -> term -> term 182 | val bvor : term -> term -> term 183 | val bvand : term -> term -> term 184 | val bvnand : term -> term -> term 185 | val bvnor : term -> term -> term 186 | val bvxnor : term -> term -> term 187 | val bvudiv : term -> term -> term 188 | val bvsdiv : term -> term -> term 189 | val bvugt : term -> term -> term 190 | val bvuge : term -> term -> term 191 | val bvult : term -> term -> term 192 | val bvule : term -> term -> term 193 | val bvneg : term -> term 194 | val bvnot : term -> term 195 | 196 | (** {1 Low-level interface} *) 197 | 198 | (** The variant of s-expressions used by SMT-LIB. *) 199 | type sexp = Smtlib_syntax.sexp = 200 | | SList of sexp list 201 | | SSymbol of string 202 | | SString of string 203 | | SKeyword of string 204 | | SInt of int 205 | | SBitVec of int * int 206 | | SBitVec64 of int64 207 | 208 | (** [command solver sexp] sends a command to the solver and reads a response. *) 209 | val command : solver -> sexp -> sexp 210 | 211 | (** [term_to_sexp term] returns the term as an s-expression. *) 212 | val term_to_sexp : term -> sexp 213 | 214 | (** [sexp_to_string sexp] returns the s-expressions as a string. *) 215 | val sexp_to_string : sexp -> string 216 | 217 | (** [fresh_name solver base] returns a fresh symbol given a base name. *) 218 | val fresh_name : solver -> string -> sexp 219 | -------------------------------------------------------------------------------- /lib/Smtlib.ml: -------------------------------------------------------------------------------- 1 | include Smtlib_syntax 2 | 3 | type solver = { stdin : out_channel; stdout : in_channel; stdout_lexbuf : Lexing.lexbuf } 4 | 5 | (* Does not flush *) 6 | let rec write_sexp (out_chan : out_channel) (e : sexp): unit = match e with 7 | | SInt n -> output_string out_chan (string_of_int n) 8 | | SBitVec (n, w) -> Printf.fprintf out_chan "(_ bv%d %d)" n w 9 | | SBitVec64 n -> Printf.fprintf out_chan "(_ bv%Ld 64)" n 10 | | SSymbol str -> output_string out_chan str 11 | | SKeyword str -> output_string out_chan str 12 | | SString str -> 13 | (output_char out_chan '('; 14 | output_string out_chan str; 15 | output_char out_chan ')') 16 | | SList lst -> 17 | (output_char out_chan '('; 18 | write_sexp_list out_chan lst; 19 | output_char out_chan ')') 20 | 21 | and write_sexp_list (out_chan : out_channel) (es : sexp list) : unit = 22 | match es with 23 | | [] -> () 24 | | [e] -> write_sexp out_chan e 25 | | e :: es -> 26 | (write_sexp out_chan e; 27 | output_char out_chan ' '; 28 | write_sexp_list out_chan es) 29 | 30 | let write (solver : solver) (e : sexp) : unit = 31 | write_sexp solver.stdin e; 32 | output_char solver.stdin '\n'; 33 | flush solver.stdin 34 | 35 | let read (solver : solver) : sexp = 36 | Smtlib_parser.sexp Smtlib_lexer.token solver.stdout_lexbuf 37 | 38 | let command (solver : solver) (sexp : sexp) = write solver sexp; read solver 39 | 40 | let silent_command (solver : solver) (sexp : sexp) = write solver sexp 41 | 42 | let print_success_command = 43 | SList [SSymbol "set-option"; SKeyword ":print-success"; SSymbol "true"] 44 | 45 | (* keep track of all solvers we spawn, so we can close our read/write 46 | FDs when the solvers exit *) 47 | let _solvers : (int * solver) list ref = ref [] 48 | 49 | module StringMap = Map.Make(String) 50 | 51 | let _names : (solver * int StringMap.t ref) list ref = ref [] 52 | 53 | let handle_sigchild (_ : int) : unit = 54 | if List.length !_solvers = 0 55 | then ignore @@ Unix.waitpid [] (-1) 56 | else 57 | begin 58 | let open Printf in 59 | let (pid, status) = Unix.waitpid [] (-1) in 60 | eprintf "solver child (pid %d) exited\n%!" pid; 61 | try 62 | let solver = List.assoc pid !_solvers in 63 | close_in_noerr solver.stdout; close_out_noerr solver.stdin 64 | with 65 | _ -> () 66 | end 67 | 68 | let () = 69 | Sys.set_signal Sys.sigchld (Sys.Signal_handle handle_sigchild) 70 | 71 | let make_solver (z3_path : string) : solver = 72 | let open Unix in 73 | let (z3_stdin, z3_stdin_writer) = pipe () in 74 | let (z3_stdout_reader, z3_stdout) = pipe () in 75 | (* If the ocaml ends of the pipes aren't marked close-on-exec, they 76 | will remain open in the fork/exec'd z3 process, and z3 won't exit 77 | when our main ocaml process ends. *) 78 | let _ = set_close_on_exec z3_stdin_writer; set_close_on_exec z3_stdout_reader in 79 | let pid = create_process z3_path [| z3_path; "-in"; "-smt2" |] 80 | z3_stdin z3_stdout stderr in 81 | let in_chan = in_channel_of_descr z3_stdout_reader in 82 | let out_chan = out_channel_of_descr z3_stdin_writer in 83 | set_binary_mode_out out_chan false; 84 | set_binary_mode_in in_chan false; 85 | let solver = { stdin = out_chan; stdout = in_chan; stdout_lexbuf = Lexing.from_channel in_chan } in 86 | _solvers := (pid, solver) :: !_solvers; 87 | _names := (solver, ref StringMap.empty) :: !_names; 88 | try 89 | match command solver print_success_command with 90 | | SSymbol "success" -> solver 91 | | _ -> failwith "could not configure solver to :print-success" 92 | with 93 | Sys_error ("Bad file descriptor") -> failwith "couldn't talk to solver, double-check path" 94 | 95 | let sexp_to_string (sexp : sexp) : string = 96 | let open Buffer in 97 | let buf = create 100 in 98 | let rec to_string (sexp : sexp) : unit = match sexp with 99 | | SList alist -> add_char buf '('; list_to_string alist; add_char buf ')' 100 | | SSymbol x -> add_string buf x; 101 | | SKeyword x -> add_string buf x; 102 | | SString x -> add_char buf '"'; add_string buf x; add_char buf '"' 103 | | SInt n -> add_string buf (string_of_int n) 104 | | SBitVec (n, w) -> add_string buf (Format.sprintf "(_ bv%d %d)" n w) 105 | | SBitVec64 n -> add_string buf (Format.sprintf "(_ bv%Ld 64)" n) 106 | and list_to_string (alist : sexp list) : unit = match alist with 107 | | [] -> () 108 | | [x] -> to_string x 109 | | x :: xs -> to_string x; add_char buf ' '; list_to_string xs in 110 | to_string sexp; 111 | contents buf 112 | 113 | let fresh_name (solver : solver) (base : string) : sexp = 114 | let names = 115 | try 116 | List.assoc solver !_names 117 | with _ -> failwith "Z3 instance doesn't have an associated fresh_name map" in 118 | try 119 | let n = StringMap.find base !names in 120 | names := StringMap.add base (n+1) !names; 121 | SSymbol (base ^ (string_of_int n)) 122 | with 123 | Not_found -> 124 | names := StringMap.add base 1 !names; 125 | SSymbol (base ^ "0") 126 | 127 | type check_sat_result = 128 | | Sat 129 | | Unsat 130 | | Unknown 131 | 132 | type identifier = 133 | | Id of string 134 | 135 | type sort = 136 | | Sort of identifier 137 | | SortApp of identifier * sort list 138 | | BitVecSort of int 139 | 140 | type term = 141 | | String of string 142 | | Int of int 143 | | BitVec of int * int 144 | | BitVec64 of int64 145 | | Const of identifier 146 | | App of identifier * term list 147 | | Let of string * term * term 148 | 149 | type tactic = 150 | | Simplify 151 | | SolveEQs 152 | | BitBlast 153 | | AIG 154 | | SAT 155 | | SMT 156 | | QFBV 157 | | UsingParams of tactic * (string * bool) list 158 | | Then of tactic list 159 | 160 | let rec tactic_to_sexp (t : tactic) : sexp = match t with 161 | | Simplify -> 162 | SSymbol "simplify" 163 | | SolveEQs -> 164 | SSymbol "solve-eqs" 165 | | BitBlast -> 166 | SSymbol "bit-blast" 167 | | AIG -> 168 | SSymbol "aig" 169 | | SAT -> 170 | SSymbol "sat" 171 | | SMT -> 172 | SSymbol "smt" 173 | | QFBV -> 174 | SSymbol "qfbv" 175 | | UsingParams (t', params) -> 176 | let param_to_sexp (keyword, value) = 177 | [ SKeyword keyword; SSymbol (string_of_bool value) ] in 178 | SList ((SSymbol "using-params") :: (tactic_to_sexp t') 179 | :: (List.concat @@ List.map param_to_sexp params)) 180 | | Then ts -> 181 | SList ((SSymbol "then") :: List.map tactic_to_sexp ts) 182 | 183 | let id_to_sexp (id : identifier) : sexp = match id with 184 | | Id x -> SSymbol x 185 | 186 | let rec sort_to_sexp (sort : sort) : sexp = match sort with 187 | | Sort x -> id_to_sexp x 188 | | SortApp (x, sorts) -> 189 | SList ((id_to_sexp x) :: (List.map sort_to_sexp sorts)) 190 | | BitVecSort n -> SList [ SSymbol "_"; SSymbol "BitVec"; SInt n ] 191 | 192 | let rec term_to_sexp (term : term) : sexp = match term with 193 | | String s -> SString s 194 | | Int n -> SInt n 195 | | BitVec (n, w) -> SBitVec (n, w) 196 | | BitVec64 n -> SBitVec64 n 197 | | Const x -> id_to_sexp x 198 | | App (f, args) -> SList (id_to_sexp f :: (List.map term_to_sexp args)) 199 | | Let (x, term1, term2) -> 200 | SList [SSymbol "let"; 201 | SList [SList [SSymbol x; term_to_sexp term1]]; 202 | term_to_sexp term2] 203 | 204 | let rec sexp_to_term (sexp : sexp) : term = match sexp with 205 | | SString s -> String s 206 | | SInt n -> Int n 207 | | SBitVec (n, w) -> BitVec (n, w) 208 | | SBitVec64 n -> BitVec64 n 209 | | SSymbol x -> Const (Id x) 210 | | SList (SSymbol "-" :: SInt x :: []) -> Int (-x) 211 | | _ -> failwith "unparsable term" 212 | 213 | let expect_success (solver : solver) (sexp : sexp) : unit = 214 | match command solver sexp with 215 | | SSymbol "success" -> () 216 | | SList [SSymbol "error"; SString x] -> failwith x 217 | | sexp -> failwith ("expected either success or error from solver, got " ^ 218 | (sexp_to_string sexp)) 219 | 220 | let declare_const (solver : solver) (id : identifier) (sort : sort) : unit = 221 | expect_success solver 222 | (SList [SSymbol "declare-const"; id_to_sexp id; sort_to_sexp sort]) 223 | 224 | let declare_fun (solver : solver) (id : identifier) (args : sort list) (sort : sort) : unit = 225 | expect_success solver 226 | (SList ([SSymbol "declare-fun"; id_to_sexp id; SList (List.map (fun s -> sort_to_sexp s) args); sort_to_sexp sort])) 227 | 228 | let declare_sort (solver : solver) (id : identifier) (arity : int) : unit = 229 | expect_success solver 230 | (SList [SSymbol "declare-sort"; id_to_sexp id; SInt arity]) 231 | 232 | let assert_ (solver : solver) (term : term) : unit = 233 | expect_success solver (SList [SSymbol "assert"; term_to_sexp term]) 234 | 235 | let assert_soft (solver : solver) ?weight:(weight = 1) ?id:(id = "") (term : term) : unit = 236 | let id_suffix = match id with 237 | | "" -> [] 238 | | _ -> [SKeyword ":id"; SSymbol id] in 239 | let sexp = 240 | (SList ([SSymbol "assert-soft"; term_to_sexp term; SKeyword ":weight"; SInt weight] @ id_suffix)) in 241 | silent_command solver sexp 242 | 243 | let maximize (solver : solver) (term : term) : unit = 244 | silent_command solver (SList ([SSymbol "maximize"; term_to_sexp term])) 245 | 246 | let minimize (solver : solver) (term : term) : unit = 247 | silent_command solver (SList ([SSymbol "minimize"; term_to_sexp term])) 248 | 249 | let read_objectives (solver : solver) : unit = 250 | match read solver with 251 | | SList [SSymbol "objectives"; SList l] -> () 252 | | s -> failwith ("unexpected result in optimized objective, got " ^ sexp_to_string s) 253 | 254 | let rec check_sat (solver : solver) : check_sat_result = 255 | let fail sexp = failwith ("unexpected result from (check-sat), got " ^ 256 | sexp_to_string sexp) in 257 | let rec read_sat sexp = 258 | let match_map () = match read solver with 259 | | SInt n -> 260 | read_sat @@ read solver 261 | | sexp -> 262 | fail sexp in 263 | match sexp with 264 | | SSymbol "sat" -> Sat 265 | | SSymbol "unsat" -> Unsat 266 | | SSymbol "unknown" -> Unknown 267 | | SSymbol "|->" -> match_map () 268 | | SSymbol sym -> read_sat @@ read solver 269 | | SList sexp -> read_sat @@ read solver 270 | | sexp -> failwith ("unexpected result from (check-sat), got " ^ 271 | sexp_to_string sexp) in 272 | read_sat @@ command solver (SList [SSymbol "check-sat"]) 273 | 274 | let rec check_sat_using (tactic : tactic) (solver : solver) : check_sat_result = 275 | let fail sexp = failwith ("unexpected result from (check-sat-using), got " ^ 276 | sexp_to_string sexp) in 277 | let rec read_sat sexp = 278 | let match_map () = match read solver with 279 | | SInt n -> 280 | read_sat @@ read solver 281 | | sexp -> 282 | fail sexp in 283 | match sexp with 284 | | SSymbol "sat" -> Sat 285 | | SSymbol "unsat" -> Unsat 286 | | SSymbol "unknown" -> Unknown 287 | | SSymbol "|->" -> match_map () 288 | | SSymbol sym -> read_sat @@ read solver 289 | | SList sexp -> read_sat @@ read solver 290 | | sexp -> failwith ("unexpected result from (check-sat-using), got " ^ 291 | sexp_to_string sexp) in 292 | let cmd = (SList [SSymbol "check-sat-using"; tactic_to_sexp tactic]) in 293 | read_sat @@ command solver cmd 294 | 295 | let get_model (solver : solver) : (identifier * term) list = 296 | let rec read_model sexp = match sexp with 297 | | [] -> [] 298 | | (SList [SSymbol "define-fun"; SSymbol x; SList []; _; sexp]) :: rest -> 299 | (Id x, sexp_to_term sexp) :: read_model rest 300 | | _ :: rest -> read_model rest in 301 | match command solver (SList [SSymbol "get-model"]) with 302 | | SList (SSymbol "model" :: alist) -> read_model alist 303 | | sexp -> failwith ("expected model, got " ^ (sexp_to_string sexp)) 304 | 305 | let get_one_value (solver : solver) (e : term) : term = 306 | let res = command solver 307 | (SList [SSymbol "get-value"; SList [term_to_sexp e]]) in 308 | match res with 309 | | SList [SList [_; x]] -> sexp_to_term x 310 | | sexp -> failwith ("expected a single pair, got " ^ 311 | (sexp_to_string sexp)) 312 | 313 | let push (solver : solver) = expect_success solver (SList [SSymbol "push"]) 314 | let pop (solver : solver) = expect_success solver (SList [SSymbol "pop"]) 315 | 316 | let int_sort = Sort (Id "Int") 317 | 318 | let bool_sort = Sort (Id "Bool") 319 | 320 | let array_sort dom rng = SortApp (Id "Array", [dom; rng]) 321 | 322 | let bv_sort w = BitVecSort w 323 | 324 | let int_to_term n = Int n 325 | 326 | let const x = Const (Id x) 327 | 328 | let bool_to_term b = match b with 329 | | true -> Const (Id "true") 330 | | false -> Const (Id "false") 331 | 332 | let app2 x term1 term2 = App (Id x, [term1; term2]) 333 | 334 | let app1 x term = App (Id x, [term]) 335 | 336 | let equals = app2 "=" 337 | 338 | let and_ term1 term2 = match (term1, term2) with 339 | | (App (Id "and", alist1), App (Id "and", alist2)) -> App (Id "and", alist1 @ alist2) 340 | | (App (Id "and", alist1), _) -> App (Id "and", alist1 @ [ term2 ]) 341 | | (_, App (Id "and", alist2)) -> App (Id "and", term1 :: alist2) 342 | | _ -> App (Id "and", [term1; term2]) 343 | 344 | let or_ term1 term2 = match (term1, term2) with 345 | | (App (Id "or", alist1), App (Id "or", alist2)) -> App (Id "or", alist1 @ alist2) 346 | | (App (Id "or", alist1), _) -> App (Id "or", alist1 @ [ term2 ]) 347 | | (_, App (Id "or", alist2)) -> App (Id "or", term1 :: alist2) 348 | | _ -> App (Id "or", [term1; term2]) 349 | 350 | let xor term1 term2 = match term1, term2 with 351 | | (App (Id "xor", alist1), App (Id "xor", alist2)) -> App (Id "xor", alist1 @ alist2) 352 | | (App (Id "xor", alist1), _) -> App (Id "xor", alist1 @ [ term2 ]) 353 | | (_, App (Id "xor", alist2)) -> App (Id "xor", term1 :: alist2) 354 | | _ -> App (Id "xor", [term1; term2]) 355 | 356 | let not_ term = App (Id "not", [term]) 357 | 358 | let ite e1 e2 e3 = App (Id "ite", [e1; e2; e3]) 359 | 360 | let implies = app2 "=>" 361 | 362 | let add = app2 "+" 363 | 364 | let sub = app2 "-" 365 | 366 | let mul = app2 "*" 367 | 368 | let lt = app2 "<" 369 | 370 | let gt = app2 ">" 371 | 372 | let lte = app2 "<=" 373 | 374 | let gte = app2 ">=" 375 | 376 | let bv n w = BitVec (n, w) 377 | 378 | let bv64 n = BitVec64 n 379 | 380 | let bvadd = app2 "bvadd" 381 | let bvsub = app2 "bvsub" 382 | let bvmul = app2 "bvmul" 383 | let bvurem = app2 "bvurem" 384 | let bvsrem = app2 "bvsrem" 385 | let bvsmod = app2 "bvsmod" 386 | let bvshl = app2 "bvshl" 387 | let bvlshr = app2 "bvlshr" 388 | let bvashr = app2 "bvashr" 389 | let bvor = app2 "bvor" 390 | let bvand = app2 "bvand" 391 | let bvnand = app2 "bvnand" 392 | let bvnor = app2 "bvnor" 393 | let bvxnor = app2 "bvxnor" 394 | let bvudiv = app2 "bvudiv" 395 | let bvsdiv = app2 "bvsdiv" 396 | let bvugt = app2 "bvugt" 397 | let bvuge = app2 "bvuge" 398 | let bvult = app2 "bvult" 399 | let bvule = app2 "bvule" 400 | let bvneg = app1 "bvneg" 401 | let bvnot = app1 "bvnot" 402 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: ee6aefb8cd19a52ee95ee294e1e43db6) *) 3 | module OASISGettext = struct 4 | (* # 22 "src/oasis/OASISGettext.ml" *) 5 | 6 | 7 | let ns_ str = str 8 | let s_ str = str 9 | let f_ (str: ('a, 'b, 'c, 'd) format4) = str 10 | 11 | 12 | let fn_ fmt1 fmt2 n = 13 | if n = 1 then 14 | fmt1^^"" 15 | else 16 | fmt2^^"" 17 | 18 | 19 | let init = [] 20 | end 21 | 22 | module OASISString = struct 23 | (* # 22 "src/oasis/OASISString.ml" *) 24 | 25 | 26 | (** Various string utilities. 27 | 28 | Mostly inspired by extlib and batteries ExtString and BatString libraries. 29 | 30 | @author Sylvain Le Gall 31 | *) 32 | 33 | 34 | let nsplitf str f = 35 | if str = "" then 36 | [] 37 | else 38 | let buf = Buffer.create 13 in 39 | let lst = ref [] in 40 | let push () = 41 | lst := Buffer.contents buf :: !lst; 42 | Buffer.clear buf 43 | in 44 | let str_len = String.length str in 45 | for i = 0 to str_len - 1 do 46 | if f str.[i] then 47 | push () 48 | else 49 | Buffer.add_char buf str.[i] 50 | done; 51 | push (); 52 | List.rev !lst 53 | 54 | 55 | (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the 56 | separator. 57 | *) 58 | let nsplit str c = 59 | nsplitf str ((=) c) 60 | 61 | 62 | let find ~what ?(offset=0) str = 63 | let what_idx = ref 0 in 64 | let str_idx = ref offset in 65 | while !str_idx < String.length str && 66 | !what_idx < String.length what do 67 | if str.[!str_idx] = what.[!what_idx] then 68 | incr what_idx 69 | else 70 | what_idx := 0; 71 | incr str_idx 72 | done; 73 | if !what_idx <> String.length what then 74 | raise Not_found 75 | else 76 | !str_idx - !what_idx 77 | 78 | 79 | let sub_start str len = 80 | let str_len = String.length str in 81 | if len >= str_len then 82 | "" 83 | else 84 | String.sub str len (str_len - len) 85 | 86 | 87 | let sub_end ?(offset=0) str len = 88 | let str_len = String.length str in 89 | if len >= str_len then 90 | "" 91 | else 92 | String.sub str 0 (str_len - len) 93 | 94 | 95 | let starts_with ~what ?(offset=0) str = 96 | let what_idx = ref 0 in 97 | let str_idx = ref offset in 98 | let ok = ref true in 99 | while !ok && 100 | !str_idx < String.length str && 101 | !what_idx < String.length what do 102 | if str.[!str_idx] = what.[!what_idx] then 103 | incr what_idx 104 | else 105 | ok := false; 106 | incr str_idx 107 | done; 108 | !what_idx = String.length what 109 | 110 | 111 | let strip_starts_with ~what str = 112 | if starts_with ~what str then 113 | sub_start str (String.length what) 114 | else 115 | raise Not_found 116 | 117 | 118 | let ends_with ~what ?(offset=0) str = 119 | let what_idx = ref ((String.length what) - 1) in 120 | let str_idx = ref ((String.length str) - 1) in 121 | let ok = ref true in 122 | while !ok && 123 | offset <= !str_idx && 124 | 0 <= !what_idx do 125 | if str.[!str_idx] = what.[!what_idx] then 126 | decr what_idx 127 | else 128 | ok := false; 129 | decr str_idx 130 | done; 131 | !what_idx = -1 132 | 133 | 134 | let strip_ends_with ~what str = 135 | if ends_with ~what str then 136 | sub_end str (String.length what) 137 | else 138 | raise Not_found 139 | 140 | 141 | let replace_chars f s = 142 | let buf = Buffer.create (String.length s) in 143 | String.iter (fun c -> Buffer.add_char buf (f c)) s; 144 | Buffer.contents buf 145 | 146 | let lowercase_ascii = 147 | replace_chars 148 | (fun c -> 149 | if (c >= 'A' && c <= 'Z') then 150 | Char.chr (Char.code c + 32) 151 | else 152 | c) 153 | 154 | let uncapitalize_ascii s = 155 | if s <> "" then 156 | (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 157 | else 158 | s 159 | 160 | let uppercase_ascii = 161 | replace_chars 162 | (fun c -> 163 | if (c >= 'a' && c <= 'z') then 164 | Char.chr (Char.code c - 32) 165 | else 166 | c) 167 | 168 | let capitalize_ascii s = 169 | if s <> "" then 170 | (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1)) 171 | else 172 | s 173 | 174 | end 175 | 176 | module OASISUtils = struct 177 | (* # 22 "src/oasis/OASISUtils.ml" *) 178 | 179 | 180 | open OASISGettext 181 | 182 | 183 | module MapExt = 184 | struct 185 | module type S = 186 | sig 187 | include Map.S 188 | val add_list: 'a t -> (key * 'a) list -> 'a t 189 | val of_list: (key * 'a) list -> 'a t 190 | val to_list: 'a t -> (key * 'a) list 191 | end 192 | 193 | module Make (Ord: Map.OrderedType) = 194 | struct 195 | include Map.Make(Ord) 196 | 197 | let rec add_list t = 198 | function 199 | | (k, v) :: tl -> add_list (add k v t) tl 200 | | [] -> t 201 | 202 | let of_list lst = add_list empty lst 203 | 204 | let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] 205 | end 206 | end 207 | 208 | 209 | module MapString = MapExt.Make(String) 210 | 211 | 212 | module SetExt = 213 | struct 214 | module type S = 215 | sig 216 | include Set.S 217 | val add_list: t -> elt list -> t 218 | val of_list: elt list -> t 219 | val to_list: t -> elt list 220 | end 221 | 222 | module Make (Ord: Set.OrderedType) = 223 | struct 224 | include Set.Make(Ord) 225 | 226 | let rec add_list t = 227 | function 228 | | e :: tl -> add_list (add e t) tl 229 | | [] -> t 230 | 231 | let of_list lst = add_list empty lst 232 | 233 | let to_list = elements 234 | end 235 | end 236 | 237 | 238 | module SetString = SetExt.Make(String) 239 | 240 | 241 | let compare_csl s1 s2 = 242 | String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2) 243 | 244 | 245 | module HashStringCsl = 246 | Hashtbl.Make 247 | (struct 248 | type t = string 249 | let equal s1 s2 = (compare_csl s1 s2) = 0 250 | let hash s = Hashtbl.hash (OASISString.lowercase_ascii s) 251 | end) 252 | 253 | module SetStringCsl = 254 | SetExt.Make 255 | (struct 256 | type t = string 257 | let compare = compare_csl 258 | end) 259 | 260 | 261 | let varname_of_string ?(hyphen='_') s = 262 | if String.length s = 0 then 263 | begin 264 | invalid_arg "varname_of_string" 265 | end 266 | else 267 | begin 268 | let buf = 269 | OASISString.replace_chars 270 | (fun c -> 271 | if ('a' <= c && c <= 'z') 272 | || 273 | ('A' <= c && c <= 'Z') 274 | || 275 | ('0' <= c && c <= '9') then 276 | c 277 | else 278 | hyphen) 279 | s; 280 | in 281 | let buf = 282 | (* Start with a _ if digit *) 283 | if '0' <= s.[0] && s.[0] <= '9' then 284 | "_"^buf 285 | else 286 | buf 287 | in 288 | OASISString.lowercase_ascii buf 289 | end 290 | 291 | 292 | let varname_concat ?(hyphen='_') p s = 293 | let what = String.make 1 hyphen in 294 | let p = 295 | try 296 | OASISString.strip_ends_with ~what p 297 | with Not_found -> 298 | p 299 | in 300 | let s = 301 | try 302 | OASISString.strip_starts_with ~what s 303 | with Not_found -> 304 | s 305 | in 306 | p^what^s 307 | 308 | 309 | let is_varname str = 310 | str = varname_of_string str 311 | 312 | 313 | let failwithf fmt = Printf.ksprintf failwith fmt 314 | 315 | 316 | let rec file_location ?pos1 ?pos2 ?lexbuf () = 317 | match pos1, pos2, lexbuf with 318 | | Some p, None, _ | None, Some p, _ -> 319 | file_location ~pos1:p ~pos2:p ?lexbuf () 320 | | Some p1, Some p2, _ -> 321 | let open Lexing in 322 | let fn, lineno = p1.pos_fname, p1.pos_lnum in 323 | let c1 = p1.pos_cnum - p1.pos_bol in 324 | let c2 = c1 + (p2.pos_cnum - p1.pos_cnum) in 325 | Printf.sprintf (f_ "file %S, line %d, characters %d-%d") fn lineno c1 c2 326 | | _, _, Some lexbuf -> 327 | file_location 328 | ~pos1:(Lexing.lexeme_start_p lexbuf) 329 | ~pos2:(Lexing.lexeme_end_p lexbuf) 330 | () 331 | | None, None, None -> 332 | s_ "" 333 | 334 | 335 | let failwithpf ?pos1 ?pos2 ?lexbuf fmt = 336 | let loc = file_location ?pos1 ?pos2 ?lexbuf () in 337 | Printf.ksprintf (fun s -> failwith (Printf.sprintf "%s: %s" loc s)) fmt 338 | 339 | 340 | end 341 | 342 | module OASISExpr = struct 343 | (* # 22 "src/oasis/OASISExpr.ml" *) 344 | 345 | 346 | open OASISGettext 347 | open OASISUtils 348 | 349 | 350 | type test = string 351 | type flag = string 352 | 353 | 354 | type t = 355 | | EBool of bool 356 | | ENot of t 357 | | EAnd of t * t 358 | | EOr of t * t 359 | | EFlag of flag 360 | | ETest of test * string 361 | 362 | 363 | type 'a choices = (t * 'a) list 364 | 365 | 366 | let eval var_get t = 367 | let rec eval' = 368 | function 369 | | EBool b -> 370 | b 371 | 372 | | ENot e -> 373 | not (eval' e) 374 | 375 | | EAnd (e1, e2) -> 376 | (eval' e1) && (eval' e2) 377 | 378 | | EOr (e1, e2) -> 379 | (eval' e1) || (eval' e2) 380 | 381 | | EFlag nm -> 382 | let v = 383 | var_get nm 384 | in 385 | assert(v = "true" || v = "false"); 386 | (v = "true") 387 | 388 | | ETest (nm, vl) -> 389 | let v = 390 | var_get nm 391 | in 392 | (v = vl) 393 | in 394 | eval' t 395 | 396 | 397 | let choose ?printer ?name var_get lst = 398 | let rec choose_aux = 399 | function 400 | | (cond, vl) :: tl -> 401 | if eval var_get cond then 402 | vl 403 | else 404 | choose_aux tl 405 | | [] -> 406 | let str_lst = 407 | if lst = [] then 408 | s_ "" 409 | else 410 | String.concat 411 | (s_ ", ") 412 | (List.map 413 | (fun (cond, vl) -> 414 | match printer with 415 | | Some p -> p vl 416 | | None -> s_ "") 417 | lst) 418 | in 419 | match name with 420 | | Some nm -> 421 | failwith 422 | (Printf.sprintf 423 | (f_ "No result for the choice list '%s': %s") 424 | nm str_lst) 425 | | None -> 426 | failwith 427 | (Printf.sprintf 428 | (f_ "No result for a choice list: %s") 429 | str_lst) 430 | in 431 | choose_aux (List.rev lst) 432 | 433 | 434 | end 435 | 436 | 437 | # 437 "myocamlbuild.ml" 438 | module BaseEnvLight = struct 439 | (* # 22 "src/base/BaseEnvLight.ml" *) 440 | 441 | 442 | module MapString = Map.Make(String) 443 | 444 | 445 | type t = string MapString.t 446 | 447 | 448 | let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" 449 | 450 | 451 | let load ?(allow_empty=false) ?(filename=default_filename) ?stream () = 452 | let line = ref 1 in 453 | let lexer st = 454 | let st_line = 455 | Stream.from 456 | (fun _ -> 457 | try 458 | match Stream.next st with 459 | | '\n' -> incr line; Some '\n' 460 | | c -> Some c 461 | with Stream.Failure -> None) 462 | in 463 | Genlex.make_lexer ["="] st_line 464 | in 465 | let rec read_file lxr mp = 466 | match Stream.npeek 3 lxr with 467 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 468 | Stream.junk lxr; Stream.junk lxr; Stream.junk lxr; 469 | read_file lxr (MapString.add nm value mp) 470 | | [] -> mp 471 | | _ -> 472 | failwith 473 | (Printf.sprintf "Malformed data file '%s' line %d" filename !line) 474 | in 475 | match stream with 476 | | Some st -> read_file (lexer st) MapString.empty 477 | | None -> 478 | if Sys.file_exists filename then begin 479 | let chn = open_in_bin filename in 480 | let st = Stream.of_channel chn in 481 | try 482 | let mp = read_file (lexer st) MapString.empty in 483 | close_in chn; mp 484 | with e -> 485 | close_in chn; raise e 486 | end else if allow_empty then begin 487 | MapString.empty 488 | end else begin 489 | failwith 490 | (Printf.sprintf 491 | "Unable to load environment, the file '%s' doesn't exist." 492 | filename) 493 | end 494 | 495 | let rec var_expand str env = 496 | let buff = Buffer.create ((String.length str) * 2) in 497 | Buffer.add_substitute 498 | buff 499 | (fun var -> 500 | try 501 | var_expand (MapString.find var env) env 502 | with Not_found -> 503 | failwith 504 | (Printf.sprintf 505 | "No variable %s defined when trying to expand %S." 506 | var 507 | str)) 508 | str; 509 | Buffer.contents buff 510 | 511 | 512 | let var_get name env = var_expand (MapString.find name env) env 513 | let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst 514 | end 515 | 516 | 517 | # 517 "myocamlbuild.ml" 518 | module MyOCamlbuildFindlib = struct 519 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 520 | 521 | 522 | (** OCamlbuild extension, copied from 523 | * https://ocaml.org/learn/tutorials/ocamlbuild/Using_ocamlfind_with_ocamlbuild.html 524 | * by N. Pouillard and others 525 | * 526 | * Updated on 2016-06-02 527 | * 528 | * Modified by Sylvain Le Gall 529 | *) 530 | open Ocamlbuild_plugin 531 | 532 | 533 | type conf = {no_automatic_syntax: bool} 534 | 535 | 536 | let run_and_read = Ocamlbuild_pack.My_unix.run_and_read 537 | 538 | 539 | let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings 540 | 541 | 542 | let exec_from_conf exec = 543 | let exec = 544 | let env = BaseEnvLight.load ~allow_empty:true () in 545 | try 546 | BaseEnvLight.var_get exec env 547 | with Not_found -> 548 | Printf.eprintf "W: Cannot get variable %s\n" exec; 549 | exec 550 | in 551 | let fix_win32 str = 552 | if Sys.os_type = "Win32" then begin 553 | let buff = Buffer.create (String.length str) in 554 | (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. 555 | *) 556 | String.iter 557 | (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) 558 | str; 559 | Buffer.contents buff 560 | end else begin 561 | str 562 | end 563 | in 564 | fix_win32 exec 565 | 566 | 567 | let split s ch = 568 | let buf = Buffer.create 13 in 569 | let x = ref [] in 570 | let flush () = 571 | x := (Buffer.contents buf) :: !x; 572 | Buffer.clear buf 573 | in 574 | String.iter 575 | (fun c -> 576 | if c = ch then 577 | flush () 578 | else 579 | Buffer.add_char buf c) 580 | s; 581 | flush (); 582 | List.rev !x 583 | 584 | 585 | let split_nl s = split s '\n' 586 | 587 | 588 | let before_space s = 589 | try 590 | String.before s (String.index s ' ') 591 | with Not_found -> s 592 | 593 | (* ocamlfind command *) 594 | let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] 595 | 596 | (* This lists all supported packages. *) 597 | let find_packages () = 598 | List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) 599 | 600 | 601 | (* Mock to list available syntaxes. *) 602 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 603 | 604 | 605 | let well_known_syntax = [ 606 | "camlp4.quotations.o"; 607 | "camlp4.quotations.r"; 608 | "camlp4.exceptiontracer"; 609 | "camlp4.extend"; 610 | "camlp4.foldgenerator"; 611 | "camlp4.listcomprehension"; 612 | "camlp4.locationstripper"; 613 | "camlp4.macro"; 614 | "camlp4.mapgenerator"; 615 | "camlp4.metagenerator"; 616 | "camlp4.profiler"; 617 | "camlp4.tracer" 618 | ] 619 | 620 | 621 | let dispatch conf = 622 | function 623 | | After_options -> 624 | (* By using Before_options one let command line options have an higher 625 | * priority on the contrary using After_options will guarantee to have 626 | * the higher priority override default commands by ocamlfind ones *) 627 | Options.ocamlc := ocamlfind & A"ocamlc"; 628 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 629 | Options.ocamldep := ocamlfind & A"ocamldep"; 630 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 631 | Options.ocamlmktop := ocamlfind & A"ocamlmktop"; 632 | Options.ocamlmklib := ocamlfind & A"ocamlmklib" 633 | 634 | | After_rules -> 635 | 636 | (* Avoid warnings for unused tag *) 637 | flag ["tests"] N; 638 | 639 | (* When one link an OCaml library/binary/package, one should use 640 | * -linkpkg *) 641 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 642 | 643 | (* For each ocamlfind package one inject the -package option when 644 | * compiling, computing dependencies, generating documentation and 645 | * linking. *) 646 | List.iter 647 | begin fun pkg -> 648 | let base_args = [A"-package"; A pkg] in 649 | (* TODO: consider how to really choose camlp4o or camlp4r. *) 650 | let syn_args = [A"-syntax"; A "camlp4o"] in 651 | let (args, pargs) = 652 | (* Heuristic to identify syntax extensions: whether they end in 653 | ".syntax"; some might not. 654 | *) 655 | if not (conf.no_automatic_syntax) && 656 | (Filename.check_suffix pkg "syntax" || 657 | List.mem pkg well_known_syntax) then 658 | (syn_args @ base_args, syn_args) 659 | else 660 | (base_args, []) 661 | in 662 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; 663 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; 664 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; 665 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; 666 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; 667 | 668 | (* TODO: Check if this is allowed for OCaml < 3.12.1 *) 669 | flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; 670 | flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; 671 | flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; 672 | flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; 673 | end 674 | (find_packages ()); 675 | 676 | (* Like -package but for extensions syntax. Morover -syntax is useless 677 | * when linking. *) 678 | List.iter begin fun syntax -> 679 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 680 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 681 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 682 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & 683 | S[A"-syntax"; A syntax]; 684 | end (find_syntaxes ()); 685 | 686 | (* The default "thread" tag is not compatible with ocamlfind. 687 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 688 | * options when using this tag. When using the "-linkpkg" option with 689 | * ocamlfind, this module will then be added twice on the command line. 690 | * 691 | * To solve this, one approach is to add the "-thread" option when using 692 | * the "threads" package using the previous plugin. 693 | *) 694 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 695 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 696 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 697 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); 698 | flag ["c"; "pkg_threads"; "compile"] (S[A "-thread"]); 699 | flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); 700 | flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); 701 | flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); 702 | flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); 703 | flag ["c"; "package(threads)"; "compile"] (S[A "-thread"]); 704 | 705 | | _ -> 706 | () 707 | end 708 | 709 | module MyOCamlbuildBase = struct 710 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 711 | 712 | 713 | (** Base functions for writing myocamlbuild.ml 714 | @author Sylvain Le Gall 715 | *) 716 | 717 | 718 | open Ocamlbuild_plugin 719 | module OC = Ocamlbuild_pack.Ocaml_compiler 720 | 721 | 722 | type dir = string 723 | type file = string 724 | type name = string 725 | type tag = string 726 | 727 | 728 | type t = 729 | { 730 | lib_ocaml: (name * dir list * string list) list; 731 | lib_c: (name * dir * file list) list; 732 | flags: (tag list * (spec OASISExpr.choices)) list; 733 | (* Replace the 'dir: include' from _tags by a precise interdepends in 734 | * directory. 735 | *) 736 | includes: (dir * dir list) list; 737 | } 738 | 739 | 740 | (* # 110 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 741 | 742 | 743 | let env_filename = Pathname.basename BaseEnvLight.default_filename 744 | 745 | 746 | let dispatch_combine lst = 747 | fun e -> 748 | List.iter 749 | (fun dispatch -> dispatch e) 750 | lst 751 | 752 | 753 | let tag_libstubs nm = 754 | "use_lib"^nm^"_stubs" 755 | 756 | 757 | let nm_libstubs nm = 758 | nm^"_stubs" 759 | 760 | 761 | let dispatch t e = 762 | let env = BaseEnvLight.load ~allow_empty:true () in 763 | match e with 764 | | Before_options -> 765 | let no_trailing_dot s = 766 | if String.length s >= 1 && s.[0] = '.' then 767 | String.sub s 1 ((String.length s) - 1) 768 | else 769 | s 770 | in 771 | List.iter 772 | (fun (opt, var) -> 773 | try 774 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 775 | with Not_found -> 776 | Printf.eprintf "W: Cannot get variable %s\n" var) 777 | [ 778 | Options.ext_obj, "ext_obj"; 779 | Options.ext_lib, "ext_lib"; 780 | Options.ext_dll, "ext_dll"; 781 | ] 782 | 783 | | After_rules -> 784 | (* Declare OCaml libraries *) 785 | List.iter 786 | (function 787 | | nm, [], intf_modules -> 788 | ocaml_lib nm; 789 | let cmis = 790 | List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi") 791 | intf_modules in 792 | dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis 793 | | nm, dir :: tl, intf_modules -> 794 | ocaml_lib ~dir:dir (dir^"/"^nm); 795 | List.iter 796 | (fun dir -> 797 | List.iter 798 | (fun str -> 799 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 800 | ["compile"; "infer_interface"; "doc"]) 801 | tl; 802 | let cmis = 803 | List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi") 804 | intf_modules in 805 | dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] 806 | cmis) 807 | t.lib_ocaml; 808 | 809 | (* Declare directories dependencies, replace "include" in _tags. *) 810 | List.iter 811 | (fun (dir, include_dirs) -> 812 | Pathname.define_context dir include_dirs) 813 | t.includes; 814 | 815 | (* Declare C libraries *) 816 | List.iter 817 | (fun (lib, dir, headers) -> 818 | (* Handle C part of library *) 819 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 820 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 821 | A("-l"^(nm_libstubs lib))]); 822 | 823 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 824 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 825 | 826 | if bool_of_string (BaseEnvLight.var_get "native_dynlink" env) then 827 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 828 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 829 | 830 | (* When ocaml link something that use the C library, then one 831 | need that file to be up to date. 832 | This holds both for programs and for libraries. 833 | *) 834 | dep ["link"; "ocaml"; tag_libstubs lib] 835 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 836 | 837 | dep ["compile"; "ocaml"; tag_libstubs lib] 838 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 839 | 840 | (* TODO: be more specific about what depends on headers *) 841 | (* Depends on .h files *) 842 | dep ["compile"; "c"] 843 | headers; 844 | 845 | (* Setup search path for lib *) 846 | flag ["link"; "ocaml"; "use_"^lib] 847 | (S[A"-I"; P(dir)]); 848 | ) 849 | t.lib_c; 850 | 851 | (* Add flags *) 852 | List.iter 853 | (fun (tags, cond_specs) -> 854 | let spec = BaseEnvLight.var_choose cond_specs env in 855 | let rec eval_specs = 856 | function 857 | | S lst -> S (List.map eval_specs lst) 858 | | A str -> A (BaseEnvLight.var_expand str env) 859 | | spec -> spec 860 | in 861 | flag tags & (eval_specs spec)) 862 | t.flags 863 | | _ -> 864 | () 865 | 866 | 867 | let dispatch_default conf t = 868 | dispatch_combine 869 | [ 870 | dispatch t; 871 | MyOCamlbuildFindlib.dispatch conf; 872 | ] 873 | 874 | 875 | end 876 | 877 | 878 | # 878 "myocamlbuild.ml" 879 | open Ocamlbuild_plugin;; 880 | let package_default = 881 | { 882 | MyOCamlbuildBase.lib_ocaml = [("z3", ["lib"], [])]; 883 | lib_c = []; 884 | flags = []; 885 | includes = [] 886 | } 887 | ;; 888 | 889 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 890 | 891 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 892 | 893 | # 894 "myocamlbuild.ml" 894 | (* OASIS_STOP *) 895 | Ocamlbuild_plugin.dispatch dispatch_default;; 896 | --------------------------------------------------------------------------------