diff --git a/bindings/Makefile b/bindings/Makefile
index ca91723594ab0992139d55ab74f41adfbd433ef1..136e5f6303db6f7e0ac98fee4d00afcfae9eef58 100644
--- a/bindings/Makefile
+++ b/bindings/Makefile
@@ -56,6 +56,9 @@ rust: FORCE
go: FORCE
cd go && $(MAKE)
+ocaml: FORCE
+ cd ocaml && $(MAKE)
+
sample_diff: FORCE
$(DIFF) $(SAMPLE_ARM)_e $(SAMPLE_ARM)_o
$(DIFF) $(SAMPLE_ARM64)_e $(SAMPLE_ARM64)_o
@@ -71,6 +74,7 @@ clean:
cd go && $(MAKE) clean
cd nodejs && $(MAKE) clean
cd ruby && $(MAKE) clean
+ cd ocaml && $(MAKE) clean
check:
cd python && $(MAKE) check
diff --git a/bindings/ocaml/.merlin b/bindings/ocaml/.merlin
new file mode 100644
index 0000000000000000000000000000000000000000..565c7625917b975b7e833495d3fa191d59bb545a
--- /dev/null
+++ b/bindings/ocaml/.merlin
@@ -0,0 +1,3 @@
+S .
+B ./_build
+PKG ctypes ctypes.foreign
\ No newline at end of file
diff --git a/bindings/ocaml/META b/bindings/ocaml/META
new file mode 100644
index 0000000000000000000000000000000000000000..e00fdcb0f7c7c2128965062acf8c6a2ce0247f0d
--- /dev/null
+++ b/bindings/ocaml/META
@@ -0,0 +1,12 @@
+# OASIS_START
+# DO NOT EDIT (digest: 9d9362d9b53fea8a38e6075c4d45bb6a)
+version = "0.1"
+description = "Ctypes bindings to Keystone assembler for OCaml"
+requires = "ctypes uchar ctypes.stubs ctypes.foreign result"
+archive(byte) = "keystone.cma"
+archive(byte, plugin) = "keystone.cma"
+archive(native) = "keystone.cmxa"
+archive(native, plugin) = "keystone.cmxs"
+exists_if = "keystone.cmxa"
+# OASIS_STOP
+
diff --git a/bindings/ocaml/Makefile b/bindings/ocaml/Makefile
new file mode 100644
index 0000000000000000000000000000000000000000..3639f14addb003984226f1a47b3c9adbfa9aa8b4
--- /dev/null
+++ b/bindings/ocaml/Makefile
@@ -0,0 +1,41 @@
+# OASIS_START
+# DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954)
+
+SETUP = ocaml setup.ml
+
+build: setup.data
+ $(SETUP) -build $(BUILDFLAGS)
+
+doc: setup.data build
+ $(SETUP) -doc $(DOCFLAGS)
+
+test: setup.data build
+ $(SETUP) -test $(TESTFLAGS)
+
+all:
+ $(SETUP) -all $(ALLFLAGS)
+
+install: setup.data
+ $(SETUP) -install $(INSTALLFLAGS)
+
+uninstall: setup.data
+ $(SETUP) -uninstall $(UNINSTALLFLAGS)
+
+reinstall: setup.data
+ $(SETUP) -reinstall $(REINSTALLFLAGS)
+
+clean:
+ $(SETUP) -clean $(CLEANFLAGS)
+
+distclean:
+ $(SETUP) -distclean $(DISTCLEANFLAGS)
+
+setup.data:
+ $(SETUP) -configure $(CONFIGUREFLAGS)
+
+configure:
+ $(SETUP) -configure $(CONFIGUREFLAGS)
+
+.PHONY: build doc test all install uninstall reinstall clean distclean configure
+
+# OASIS_STOP
diff --git a/bindings/ocaml/README b/bindings/ocaml/README
new file mode 100644
index 0000000000000000000000000000000000000000..45ef11f0b9bacd84ae202daf3a23748d6f01d244
--- /dev/null
+++ b/bindings/ocaml/README
@@ -0,0 +1,27 @@
+OCaml bindings to the Keystone library (www.keytone-engine.org)
+
+Make sure Keystone is built and installed.
+
+Requires OCaml (>= 4.01.0) and Opam (optionally Oasis)
+
+If Keystone was not installed in the default location then the
+keystone_header_loc variable in config.ml needs to be set to the
+correct location. The default location is
+"/usr/local/include/keystone/keystone.h"
+
+
+To Build:
+
+1. Install opam
+
+2. Install necessary packages:
+
+ opam install ctypes ctypes-foreign uchar result ocamlfind
+
+4. Run make
+
+To rebuild the build files (make, configure etc) run oasis setup
+
+To install the bindings run make install
+
+To build documentation run make doc
diff --git a/bindings/ocaml/_oasis b/bindings/ocaml/_oasis
new file mode 100644
index 0000000000000000000000000000000000000000..30e9ff2b9b1031866e94934c1f0cfb5d92cdb787
--- /dev/null
+++ b/bindings/ocaml/_oasis
@@ -0,0 +1,50 @@
+OASISFormat: 0.4
+OCamlVersion: >= 4.01
+Name: keystone
+Version: 0.1
+Synopsis: Ctypes bindings to Keystone assembler for OCaml
+Authors: Aziem Chawdhary
+License: LGPL-2.1 with OCaml linking exception
+Plugins: DevFiles (0.4), META (0.4)
+BuildTools: ocamlbuild
+
+Library keystone
+ FindLibName: keystone
+ Install: true
+ Path: .
+ Modules: Keystone, Ffi_generated, Ffi_types, Ffi_bindings, Ffi_generated_types
+ CSources: ffi_generated_stubs.c
+ CCLib: -lkeystone
+ CCOpt: -I $pkg_ctypes_stubs
+ BuildDepends: ctypes, uchar, ctypes.stubs, ctypes.foreign, result
+ CompiledObject: native
+
+Document keystone
+ Type: ocamlbuild (0.4)
+ Install: true
+ BuildTools : ocamldoc
+ Title: API reference for Keystone
+ XOCamlBuildPath: .
+ XOCamlBuildlibraries: keystone
+
+Executable ffi_types_stubgen
+ Install: false
+ Path: .
+ MainIs: ffi_types_stubgen.ml
+ BuildDepends: ctypes.stubs
+ CompiledObject: native
+
+Executable ffi_stubgen
+ Install: false
+ Path: .
+ MainIs: ffi_stubgen.ml
+ BuildDepends: ctypes.stubs, ctypes.foreign
+ CompiledObject : native
+
+Executable test_bindings
+ Install: false
+ CCLib: -lkeystone
+ Path: .
+ MainIs: test_bindings.ml
+ BuildDepends: keystone
+ CompiledObject: native
diff --git a/bindings/ocaml/_tags b/bindings/ocaml/_tags
new file mode 100644
index 0000000000000000000000000000000000000000..cc23b787f790d44fad68abd222d2a1548dbf9a3b
--- /dev/null
+++ b/bindings/ocaml/_tags
@@ -0,0 +1,51 @@
+# OASIS_START
+# DO NOT EDIT (digest: 56649e18999b9e9fdb9cc2eb938aa836)
+# Ignore VCS directories, you can use the same kind of rule outside
+# OASIS_START/STOP if you want to exclude directories that contains
+# useless stuff for the build process
+true: annot, bin_annot
+<**/.svn>: -traverse
+<**/.svn>: not_hygienic
+".bzr": -traverse
+".bzr": not_hygienic
+".hg": -traverse
+".hg": not_hygienic
+".git": -traverse
+".git": not_hygienic
+"_darcs": -traverse
+"_darcs": not_hygienic
+# Library keystone
+"keystone.cmxs": use_keystone
+<*.ml{,i,y}>: oasis_library_keystone_ccopt
+"ffi_generated_stubs.c": oasis_library_keystone_ccopt
+"keystone.cmxa": oasis_library_keystone_cclib
+"libkeystone_stubs.lib": oasis_library_keystone_cclib
+"dllkeystone_stubs.dll": oasis_library_keystone_cclib
+"libkeystone_stubs.a": oasis_library_keystone_cclib
+"dllkeystone_stubs.so": oasis_library_keystone_cclib
+"keystone.cmxa": use_libkeystone_stubs
+"ffi_generated_stubs.c": package(ctypes)
+"ffi_generated_stubs.c": package(ctypes.foreign)
+"ffi_generated_stubs.c": package(ctypes.stubs)
+"ffi_generated_stubs.c": package(result)
+"ffi_generated_stubs.c": package(uchar)
+# Executable ffi_types_stubgen
+"ffi_types_stubgen.native": package(ctypes.stubs)
+# Executable ffi_stubgen
+"ffi_stubgen.native": package(ctypes.foreign)
+"ffi_stubgen.native": package(ctypes.stubs)
+# Executable test_bindings
+"test_bindings.native": oasis_executable_test_bindings_cclib
+"test_bindings.native": package(ctypes)
+"test_bindings.native": package(ctypes.foreign)
+"test_bindings.native": package(ctypes.stubs)
+"test_bindings.native": package(result)
+"test_bindings.native": package(uchar)
+"test_bindings.native": use_keystone
+<*.ml{,i,y}>: package(ctypes)
+<*.ml{,i,y}>: package(ctypes.foreign)
+<*.ml{,i,y}>: package(ctypes.stubs)
+<*.ml{,i,y}>: package(result)
+<*.ml{,i,y}>: package(uchar)
+<*.ml{,i,y}>: use_keystone
+# OASIS_STOP
diff --git a/bindings/ocaml/config.ml b/bindings/ocaml/config.ml
new file mode 100644
index 0000000000000000000000000000000000000000..90eb252ace600e3694c7d36dc553754a3dd09d54
--- /dev/null
+++ b/bindings/ocaml/config.ml
@@ -0,0 +1 @@
+let keystone_header_loc = "\"/usr/local/include/keystone/keystone.h\""
diff --git a/bindings/ocaml/configure b/bindings/ocaml/configure
new file mode 100755
index 0000000000000000000000000000000000000000..6acfaeb953f7778c285f85f3e41ac0adfd6188fb
--- /dev/null
+++ b/bindings/ocaml/configure
@@ -0,0 +1,27 @@
+#!/bin/sh
+
+# OASIS_START
+# DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499)
+set -e
+
+FST=true
+for i in "$@"; do
+ if $FST; then
+ set --
+ FST=false
+ fi
+
+ case $i in
+ --*=*)
+ ARG=${i%%=*}
+ VAL=${i##*=}
+ set -- "$@" "$ARG" "$VAL"
+ ;;
+ *)
+ set -- "$@" "$i"
+ ;;
+ esac
+done
+
+ocaml setup.ml -configure "$@"
+# OASIS_STOP
diff --git a/bindings/ocaml/ffi_bindings.ml b/bindings/ocaml/ffi_bindings.ml
new file mode 100644
index 0000000000000000000000000000000000000000..e9db3c6dfc85c7be7e9bb6cc35da723ede2bd3ed
--- /dev/null
+++ b/bindings/ocaml/ffi_bindings.ml
@@ -0,0 +1,30 @@
+open Ctypes
+
+module Bindings (F: Cstubs.FOREIGN) =
+ struct
+
+ open F
+
+ module T = Ffi_types.Types(Ffi_generated_types)
+
+ let temp = Ffi_generated_types.constant "KS_MODE_BIG_ENDIAN" int64_t
+
+ let ks_arch_supported_ = foreign "ks_arch_supported" (T.ks_arch @-> returning bool)
+
+ let ks_version_ = foreign "ks_version" (ptr uint @-> ptr uint @-> returning uint)
+
+ let ks_open_ = foreign "ks_open" (T.ks_arch @-> int64_t @-> (ptr (ptr T.ks_engine)) @-> returning T.ks_err)
+
+ let ks_close_ = foreign "ks_close" (ptr T.ks_engine @-> returning int64_t)
+
+ let ks_err_ = foreign "ks_errno" (ptr T.ks_engine @-> returning T.ks_err)
+
+ let ks_option_ = foreign "ks_option" (ptr T.ks_engine @-> T.ks_opt_type @-> T.ks_opt_value @-> returning T.ks_err)
+
+ let ks_strerror_ = foreign "ks_strerror" (T.ks_err @-> returning string)
+
+ let ks_free_ = foreign "ks_free" (ptr void @-> returning void)
+
+ let ks_asm_ = foreign "ks_asm" (ptr T.ks_engine @-> string @-> int64_t @-> ptr (ptr uchar) @-> ptr size_t @-> ptr size_t @-> returning int)
+
+ end
diff --git a/bindings/ocaml/ffi_stubgen.ml b/bindings/ocaml/ffi_stubgen.ml
new file mode 100644
index 0000000000000000000000000000000000000000..3a3d24ecb94ada208f41e58f9665bfcabcb37203
--- /dev/null
+++ b/bindings/ocaml/ffi_stubgen.ml
@@ -0,0 +1,16 @@
+let _ =
+ let prefix = "keystone_stub" in
+ let generate_ml, generate_c = ref false, ref false in
+ Arg.(parse [ ("-ml", Set generate_ml, "Generate ML");
+ ("-c", Set generate_c, "Generate C") ])
+ (fun _ -> failwith "unexpected anonymous argument")
+ "stubgen [-ml|-c]";
+ match !generate_ml, !generate_c with
+ | false, false
+ | true, true ->
+ failwith "Exactly one of -ml and -c must be specified"
+ | true, false ->
+ Cstubs.write_ml Format.std_formatter ~prefix (module Ffi_bindings.Bindings)
+ | false, true ->
+ print_endline ("#include " ^ Config.keystone_header_loc);
+ Cstubs.write_c Format.std_formatter ~prefix (module Ffi_bindings.Bindings)
diff --git a/bindings/ocaml/ffi_types.ml b/bindings/ocaml/ffi_types.ml
new file mode 100644
index 0000000000000000000000000000000000000000..acfb048a8a9f715a44aafc4794372ad16488cdf8
--- /dev/null
+++ b/bindings/ocaml/ffi_types.ml
@@ -0,0 +1,530 @@
+open Ctypes
+
+module Types (F: Cstubs.Types.TYPE) =
+ struct
+
+ open F
+
+ type ks_struct
+ let ks_struct : ks_struct structure typ = structure "ks_struct"
+
+ type ks_engine
+ let ks_engine = typedef ks_struct "ks_engine"
+
+ type ks_t = ks_struct structure ptr
+ let ks_t : ks_struct structure ptr typ = ptr ks_engine
+
+ (** Architecture type *)
+ type ks_arch =
+ | KS_ARCH_ARM
+ | KS_ARCH_ARM64
+ | KS_ARCH_MIPS
+ | KS_ARCH_X86
+ | KS_ARCH_PPC
+ | KS_ARCH_SPARC
+ | KS_ARCH_SYSTEMZ
+ | KS_ARCH_HEXAGON
+ | KS_ARCH_MAX
+
+
+ (** Error type: please refer to keystone.h for a full description. *)
+ type ks_error =
+ | KS_ERR_OK
+ | KS_ERR_NOMEM
+ | KS_ERR_ARCH
+ | KS_ERR_HANDLE
+ | KS_ERR_MODE
+ | KS_ERR_VERSION
+ | KS_ERR_OPT_INVALID
+ | KS_ERR_ASM_EXPR_TOKEN
+ | KS_ERR_ASM_DIRECTIVE_VALUE_RANGE
+ | KS_ERR_ASM_DIRECTIVE_ID
+ | KS_ERR_ASM_DIRECTIVE_TOKEN
+ | KS_ERR_ASM_DIRECTIVE_STR
+ | KS_ERR_ASM_DIRECTIVE_COMMA
+ | KS_ERR_ASM_DIRECTIVE_RELOC_NAME
+ | KS_ERR_ASM_DIRECTIVE_RELOC_TOKEN
+ | KS_ERR_ASM_DIRECTIVE_FPOINT
+ | KS_ERR_ASM_DIRECTIVE_UNKNOWN
+ | KS_ERR_ASM_VARIANT_INVALID
+ | KS_ERR_ASM_DIRECTIVE_EQU
+ | KS_ERR_ASM_EXPR_BRACKET
+ | KS_ERR_ASM_SYMBOL_MODIFIER
+ | KS_ERR_ASM_SYMBOL_REDEFINED
+ | KS_ERR_ASM_SYMBOL_MISSING
+ | KS_ERR_ASM_RPAREN
+ | KS_ERR_ASM_STAT_TOKEN
+ | KS_ERR_ASM_UNSUPPORTED
+ | KS_ERR_ASM_MACRO_TOKEN
+ | KS_ERR_ASM_MACRO_PAREN
+ | KS_ERR_ASM_MACRO_EQU
+ | KS_ERR_ASM_MACRO_ARGS
+ | KS_ERR_ASM_MACRO_LEVELS_EXCEED
+ | KS_ERR_ASM_MACRO_STR
+ | KS_ERR_ASM_ESC_BACKSLASH
+ | KS_ERR_ASM_ESC_OCTAL
+ | KS_ERR_ASM_ESC_SEQUENCE
+ | KS_ERR_ASM_ESC_STR
+ | KS_ERR_ASM_TOKEN_INVALID
+ | KS_ERR_ASM_INSN_UNSUPPORTED
+ | KS_ERR_ASM_FIXUP_INVALID
+ | KS_ERR_ASM_LABEL_INVALID
+ | KS_ERR_ASM_FRAGMENT_INVALID
+ | KS_ERR_ASM_INVALIDOPERAND
+ | KS_ERR_ASM_MISSINGFEATURE
+ | KS_ERR_ASM_MNEMONICFAIL
+
+ let string_of_ks_error = function
+ | KS_ERR_OK -> "KS_ERR_OK"
+ | KS_ERR_NOMEM -> "KS_ERR_NOMEM"
+ | KS_ERR_ARCH -> "KS_ERR_ARCH"
+ | KS_ERR_HANDLE -> "KS_ERR_HANDLE"
+ | KS_ERR_MODE -> "KS_ERR_MODE"
+ | KS_ERR_VERSION -> "KS_ERR_VERSION"
+ | KS_ERR_OPT_INVALID -> "KS_ERR_OPT_INVALID"
+ | KS_ERR_ASM_EXPR_TOKEN -> "KS_ERR_ASM_EXPR_TOKEN"
+ | KS_ERR_ASM_DIRECTIVE_VALUE_RANGE -> "KS_ERR_ASM_DIRECTIVE_VALUE_RANGE"
+ | KS_ERR_ASM_DIRECTIVE_ID -> "KS_ERR_ASM_DIRECTIVE_ID"
+ | KS_ERR_ASM_DIRECTIVE_TOKEN -> "KS_ERR_ASM_DIRECTIVE_TOKEN"
+ | KS_ERR_ASM_DIRECTIVE_STR -> "KS_ERR_ASM_DIRECTIVE_STR"
+ | KS_ERR_ASM_DIRECTIVE_COMMA -> "KS_ERR_ASM_DIRECTIVE_COMMA"
+ | KS_ERR_ASM_DIRECTIVE_RELOC_NAME -> "KS_ERR_ASM_DIRECTIVE_RELOC_NAME"
+ | KS_ERR_ASM_DIRECTIVE_RELOC_TOKEN -> "KS_ERR_ASM_DIRECTIVE_RELOC_TOKEN"
+ | KS_ERR_ASM_DIRECTIVE_FPOINT -> "KS_ERR_ASM_DIRECTIVE_FPOINT"
+ | KS_ERR_ASM_DIRECTIVE_UNKNOWN -> "KS_ERR_ASM_DIRECTIVE_UNKNOWN"
+ | KS_ERR_ASM_VARIANT_INVALID -> "KS_ERR_ASM_VARIANT_INVALID"
+ | KS_ERR_ASM_DIRECTIVE_EQU -> "KS_ERR_ASM_DIRECTIVE_EQU"
+ | KS_ERR_ASM_EXPR_BRACKET -> "KS_ERR_ASM_EXPR_BRACKET"
+ | KS_ERR_ASM_SYMBOL_MODIFIER -> "KS_ERR_ASM_SYMBOL_MODIFIER"
+ | KS_ERR_ASM_SYMBOL_REDEFINED -> "KS_ERR_ASM_SYMBOL_REDEFINED"
+ | KS_ERR_ASM_SYMBOL_MISSING -> "KS_ERR_ASM_SYMBOL_MISSING"
+ | KS_ERR_ASM_RPAREN -> "KS_ERR_ASM_RPAREN"
+ | KS_ERR_ASM_STAT_TOKEN -> "KS_ERR_ASM_STAT_TOKEN"
+ | KS_ERR_ASM_UNSUPPORTED -> "KS_ERR_ASM_UNSUPPORTED"
+ | KS_ERR_ASM_MACRO_TOKEN -> "KS_ERR_ASM_MACRO_TOKEN"
+ | KS_ERR_ASM_MACRO_PAREN -> "KS_ERR_ASM_MACRO_PAREN"
+ | KS_ERR_ASM_MACRO_EQU -> "KS_ERR_ASM_MACRO_EQU"
+ | KS_ERR_ASM_MACRO_ARGS -> "KS_ERR_ASM_MACRO_ARGS"
+ | KS_ERR_ASM_MACRO_LEVELS_EXCEED -> "KS_ERR_ASM_MACRO_LEVELS_EXCEED"
+ | KS_ERR_ASM_MACRO_STR -> "KS_ERR_ASM_MACRO_STR"
+ | KS_ERR_ASM_ESC_BACKSLASH -> "KS_ERR_ASM_ESC_BACKSLASH"
+ | KS_ERR_ASM_ESC_OCTAL -> "KS_ERR_ASM_ESC_OCTAL"
+ | KS_ERR_ASM_ESC_SEQUENCE -> "KS_ERR_ASM_ESC_SEQUENCE"
+ | KS_ERR_ASM_ESC_STR -> "KS_ERR_ASM_ESC_STR "
+ | KS_ERR_ASM_TOKEN_INVALID -> "KS_ERR_ASM_TOKEN_INVALID"
+ | KS_ERR_ASM_INSN_UNSUPPORTED -> "KS_ERR_ASM_INSN_UNSUPPORTED"
+ | KS_ERR_ASM_FIXUP_INVALID -> "KS_ERR_ASM_FIXUP_INVALID "
+ | KS_ERR_ASM_LABEL_INVALID -> "KS_ERR_ASM_LABEL_INVALID "
+ | KS_ERR_ASM_FRAGMENT_INVALID -> "KS_ERR_ASM_FRAGMENT_INVALID"
+ | KS_ERR_ASM_INVALIDOPERAND -> "KS_ERR_ASM_INVALIDOPERAND"
+ | KS_ERR_ASM_MISSINGFEATURE -> "KS_ERR_ASM_MISSINGFEATURE"
+ | KS_ERR_ASM_MNEMONICFAIL -> "KS_ERR_ASM_MNEMONICFAIL "
+
+
+ let ks_err_ok = constant "KS_ERR_OK" int64_t
+ let ks_err_nomem = constant "KS_ERR_NOMEM" int64_t
+ let ks_err_arch = constant "KS_ERR_ARCH" int64_t
+ let ks_err_handle = constant "KS_ERR_HANDLE" int64_t
+ let ks_err_mode = constant "KS_ERR_MODE" int64_t
+ let ks_err_version = constant "KS_ERR_VERSION" int64_t
+ let ks_err_opt_invalid = constant "KS_ERR_OPT_INVALID" int64_t
+ let ks_err_asm_expr_token = constant "KS_ERR_ASM_EXPR_TOKEN" int64_t
+ let ks_err_asm_directive_value_range = constant "KS_ERR_ASM_DIRECTIVE_VALUE_RANGE" int64_t
+ let ks_err_asm_directive_id = constant "KS_ERR_ASM_DIRECTIVE_ID" int64_t
+ let ks_err_asm_directive_token = constant "KS_ERR_ASM_DIRECTIVE_TOKEN" int64_t
+ let ks_err_asm_directive_str = constant "KS_ERR_ASM_DIRECTIVE_STR" int64_t
+ let ks_err_asm_directive_comma = constant "KS_ERR_ASM_DIRECTIVE_COMMA" int64_t
+ let ks_err_asm_directive_reloc_name = constant "KS_ERR_ASM_DIRECTIVE_RELOC_NAME" int64_t
+ let ks_err_asm_directive_reloc_token = constant "KS_ERR_ASM_DIRECTIVE_RELOC_TOKEN" int64_t
+ let ks_err_asm_directive_fpoint = constant "KS_ERR_ASM_DIRECTIVE_FPOINT" int64_t
+ let ks_err_asm_directive_unknown = constant "KS_ERR_ASM_DIRECTIVE_UNKNOWN" int64_t
+ let ks_err_asm_variant_invalid = constant "KS_ERR_ASM_VARIANT_INVALID" int64_t
+ let ks_err_asm_directive_equ = constant "KS_ERR_ASM_DIRECTIVE_EQU" int64_t
+ let ks_err_asm_expr_bracket = constant "KS_ERR_ASM_EXPR_BRACKET" int64_t
+ let ks_err_asm_symbol_modifier = constant "KS_ERR_ASM_SYMBOL_MODIFIER" int64_t
+ let ks_err_asm_symbol_redefined = constant "KS_ERR_ASM_SYMBOL_REDEFINED" int64_t
+ let ks_err_asm_symbol_missing = constant "KS_ERR_ASM_SYMBOL_MISSING" int64_t
+ let ks_err_asm_rparen = constant "KS_ERR_ASM_RPAREN" int64_t
+ let ks_err_asm_stat_token = constant "KS_ERR_ASM_STAT_TOKEN" int64_t
+ let ks_err_asm_unsupported = constant "KS_ERR_ASM_UNSUPPORTED" int64_t
+ let ks_err_asm_macro_token = constant "KS_ERR_ASM_MACRO_TOKEN" int64_t
+ let ks_err_asm_macro_paren = constant "KS_ERR_ASM_MACRO_PAREN" int64_t
+ let ks_err_asm_macro_equ = constant "KS_ERR_ASM_MACRO_EQU" int64_t
+ let ks_err_asm_macro_args = constant "KS_ERR_ASM_MACRO_ARGS" int64_t
+ let ks_err_asm_macro_levels_exceed = constant "KS_ERR_ASM_MACRO_LEVELS_EXCEED" int64_t
+ let ks_err_asm_macro_str = constant "KS_ERR_ASM_MACRO_STR" int64_t
+ let ks_err_asm_esc_backslash = constant "KS_ERR_ASM_ESC_BACKSLASH" int64_t
+ let ks_err_asm_esc_octal = constant "KS_ERR_ASM_ESC_OCTAL" int64_t
+ let ks_err_asm_esc_sequence = constant "KS_ERR_ASM_ESC_SEQUENCE" int64_t
+ let ks_err_asm_esc_str = constant "KS_ERR_ASM_ESC_STR" int64_t
+ let ks_err_asm_token_invalid = constant "KS_ERR_ASM_TOKEN_INVALID" int64_t
+ let ks_err_asm_insn_unsupported = constant "KS_ERR_ASM_INSN_UNSUPPORTED" int64_t
+ let ks_err_asm_fixup_invalid = constant "KS_ERR_ASM_FIXUP_INVALID" int64_t
+ let ks_err_asm_label_invalid = constant "KS_ERR_ASM_LABEL_INVALID" int64_t
+ let ks_err_asm_fragment_invalid = constant "KS_ERR_ASM_FRAGMENT_INVALID" int64_t
+ let ks_err_asm_invalidoperand = constant "KS_ERR_ASM_INVALIDOPERAND" int64_t
+ let ks_err_asm_missingfeature = constant "KS_ERR_ASM_MISSINGFEATURE" int64_t
+ let ks_err_asm_mnemonicfail = constant "KS_ERR_ASM_MNEMONICFAIL" int64_t
+
+ let ks_err = enum "ks_err" [
+ KS_ERR_OK, ks_err_ok;
+ KS_ERR_NOMEM, ks_err_nomem;
+ KS_ERR_ARCH, ks_err_arch;
+ KS_ERR_HANDLE, ks_err_handle;
+ KS_ERR_MODE, ks_err_mode;
+ KS_ERR_VERSION, ks_err_version;
+ KS_ERR_OPT_INVALID, ks_err_opt_invalid;
+ KS_ERR_ASM_EXPR_TOKEN, ks_err_asm_expr_token;
+ KS_ERR_ASM_DIRECTIVE_VALUE_RANGE, ks_err_asm_directive_value_range;
+ KS_ERR_ASM_DIRECTIVE_ID, ks_err_asm_directive_id;
+ KS_ERR_ASM_DIRECTIVE_TOKEN, ks_err_asm_directive_token;
+ KS_ERR_ASM_DIRECTIVE_STR, ks_err_asm_directive_str;
+ KS_ERR_ASM_DIRECTIVE_COMMA, ks_err_asm_directive_comma;
+ KS_ERR_ASM_DIRECTIVE_RELOC_NAME, ks_err_asm_directive_reloc_name;
+ KS_ERR_ASM_DIRECTIVE_RELOC_TOKEN, ks_err_asm_directive_reloc_token;
+ KS_ERR_ASM_DIRECTIVE_FPOINT, ks_err_asm_directive_fpoint;
+ KS_ERR_ASM_DIRECTIVE_UNKNOWN, ks_err_asm_directive_unknown;
+ KS_ERR_ASM_VARIANT_INVALID, ks_err_asm_variant_invalid;
+ KS_ERR_ASM_DIRECTIVE_EQU, ks_err_asm_directive_equ;
+ KS_ERR_ASM_EXPR_BRACKET, ks_err_asm_expr_bracket;
+ KS_ERR_ASM_SYMBOL_MODIFIER, ks_err_asm_symbol_modifier;
+ KS_ERR_ASM_SYMBOL_REDEFINED, ks_err_asm_symbol_redefined;
+ KS_ERR_ASM_SYMBOL_MISSING, ks_err_asm_symbol_missing;
+ KS_ERR_ASM_RPAREN, ks_err_asm_rparen;
+ KS_ERR_ASM_STAT_TOKEN, ks_err_asm_stat_token;
+ KS_ERR_ASM_UNSUPPORTED, ks_err_asm_unsupported;
+ KS_ERR_ASM_MACRO_TOKEN, ks_err_asm_macro_token;
+ KS_ERR_ASM_MACRO_PAREN, ks_err_asm_macro_paren;
+ KS_ERR_ASM_MACRO_EQU, ks_err_asm_macro_equ;
+ KS_ERR_ASM_MACRO_ARGS, ks_err_asm_macro_args;
+ KS_ERR_ASM_MACRO_LEVELS_EXCEED, ks_err_asm_macro_levels_exceed;
+ KS_ERR_ASM_MACRO_STR, ks_err_asm_macro_str;
+ KS_ERR_ASM_ESC_BACKSLASH, ks_err_asm_esc_backslash;
+ KS_ERR_ASM_ESC_OCTAL, ks_err_asm_esc_octal;
+ KS_ERR_ASM_ESC_SEQUENCE, ks_err_asm_esc_sequence;
+ KS_ERR_ASM_ESC_STR , ks_err_asm_esc_str ;
+ KS_ERR_ASM_TOKEN_INVALID, ks_err_asm_token_invalid;
+ KS_ERR_ASM_INSN_UNSUPPORTED, ks_err_asm_insn_unsupported;
+ KS_ERR_ASM_FIXUP_INVALID , ks_err_asm_fixup_invalid ;
+ KS_ERR_ASM_LABEL_INVALID , ks_err_asm_label_invalid ;
+ KS_ERR_ASM_FRAGMENT_INVALID, ks_err_asm_fragment_invalid;
+ KS_ERR_ASM_INVALIDOPERAND, ks_err_asm_invalidoperand;
+ KS_ERR_ASM_MISSINGFEATURE, ks_err_asm_missingfeature;
+ KS_ERR_ASM_MNEMONICFAIL , ks_err_asm_mnemonicfail
+ ]
+
+ let ks_arch_arm = constant "KS_ARCH_ARM" int64_t
+ let ks_arch_arm64 = constant "KS_ARCH_ARM64" int64_t
+ let ks_arch_mips = constant "KS_ARCH_MIPS" int64_t
+ let ks_arch_x86 = constant "KS_ARCH_X86" int64_t
+ let ks_arch_ppc = constant "KS_ARCH_PPC" int64_t
+ let ks_arch_sparc = constant "KS_ARCH_SPARC" int64_t
+ let ks_arch_systemz = constant "KS_ARCH_SYSTEMZ" int64_t
+ let ks_arch_hexagon = constant "KS_ARCH_HEXAGON" int64_t
+ let ks_arch_max = constant "KS_ARCH_MAX" int64_t
+
+ let ks_arch = enum "ks_arch" [
+ KS_ARCH_ARM, ks_arch_arm;
+ KS_ARCH_ARM64, ks_arch_arm64;
+ KS_ARCH_MIPS, ks_arch_mips;
+ KS_ARCH_X86, ks_arch_x86;
+ KS_ARCH_PPC, ks_arch_ppc;
+ KS_ARCH_SPARC, ks_arch_sparc;
+ KS_ARCH_SYSTEMZ, ks_arch_systemz;
+ KS_ARCH_HEXAGON, ks_arch_hexagon;
+ KS_ARCH_MAX, ks_arch_max
+ ]
+
+
+ let ks_api_major = constant "KS_API_MAJOR" int
+ let ks_api_minor = constant "KS_API_MINOR" int
+
+ (** Mode type: refer to keystone.h for a full description *)
+ type ks_mode =
+ | KS_MODE_ARM
+ | KS_MODE_BIG_ENDIAN
+ | KS_MODE_LITTLE_ENDIAN
+ | KS_MODE_THUMB
+ | KS_MODE_V8
+ | KS_MODE_MICRO
+ | KS_MODE_MIPS3
+ | KS_MODE_MIPS32R6
+ | KS_MODE_MIPS32
+ | KS_MODE_MIPS64
+ | KS_MODE_16
+ | KS_MODE_32
+ | KS_MODE_64
+ | KS_MODE_PPC32
+ | KS_MODE_PPC64
+ | KS_MODE_QPX
+ | KS_MODE_SPARC32
+ | KS_MODE_SPARC64
+ | KS_MODE_V9
+
+
+
+ let string_of_ks_mode = function
+ | KS_MODE_ARM -> "KS_MODE_ARM"
+ | KS_MODE_BIG_ENDIAN -> "KS_MODE_BIG_ENDIAN"
+ | KS_MODE_LITTLE_ENDIAN -> "KS_MODE_LITTLE_ENDIAN"
+ | KS_MODE_THUMB -> "KS_MODE_THUMB"
+ | KS_MODE_V8 -> "KS_MODE_V8"
+ | KS_MODE_MICRO -> "KS_MODE_MICRO"
+ | KS_MODE_MIPS3 -> "KS_MODE_MIPS3"
+ | KS_MODE_MIPS32R6 -> "KS_MODE_MIPS32R6"
+ | KS_MODE_MIPS32 -> "KS_MODE_MIPS32"
+ | KS_MODE_MIPS64 -> "KS_MODE_MIPS64"
+ | KS_MODE_16 -> "KS_MODE_16"
+ | KS_MODE_32 -> "KS_MODE_32"
+ | KS_MODE_64 -> "KS_MODE_64"
+ | KS_MODE_PPC32 -> "KS_MODE_PPC32"
+ | KS_MODE_PPC64 -> "KS_MODE_PPC64"
+ | KS_MODE_QPX -> "KS_MODE_QPX"
+ | KS_MODE_SPARC32 -> "KS_MODE_SPARC32"
+ | KS_MODE_SPARC64 -> "KS_MODE_SPARC64"
+ | KS_MODE_V9 -> "KS_MODE_V9"
+
+
+
+
+
+ let ks_mode_little_endian = constant "KS_MODE_LITTLE_ENDIAN" int64_t
+ let ks_mode_big_endian = constant "KS_MODE_BIG_ENDIAN" int64_t
+ let ks_mode_arm = constant "KS_MODE_ARM" int64_t
+
+ let ks_mode_thumb = constant "KS_MODE_THUMB" int64_t
+
+ let ks_mode_v8 = constant "KS_MODE_V8" int64_t
+ let ks_mode_micro = constant "KS_MODE_MICRO" int64_t
+ let ks_mode_mips3 = constant "KS_MODE_MIPS3" int64_t
+ let ks_mode_mips32r6 = constant "KS_MODE_MIPS32R6" int64_t
+ let ks_mode_mips32 = constant "KS_MODE_MIPS32" int64_t
+ let ks_mode_mips64 = constant "KS_MODE_MIPS64" int64_t
+ let ks_mode_16 = constant "KS_MODE_16" int64_t
+ let ks_mode_32 = constant "KS_MODE_32" int64_t
+ let ks_mode_64 = constant "KS_MODE_64" int64_t
+ let ks_mode_ppc32 = constant "KS_MODE_PPC32" int64_t
+ let ks_mode_ppc64 = constant "KS_MODE_PPC64" int64_t
+ let ks_mode_qpx = constant "KS_MODE_QPX" int64_t
+ let ks_mode_sparc32 = constant "KS_MODE_SPARC32" int64_t
+ let ks_mode_sparc64 = constant "KS_MODE_SPARC64" int64_t
+ let ks_mode_v9 = constant "KS_MODE_V9" int64_t
+
+ let ks_mode = enum "ks_mode" [
+ (*KS_MODE_LITTLE_ENDIAN, ks_mode_little_endian;
+ KS_MODE_BIG_ENDIAN, ks_mode_big_endian;*)
+ KS_MODE_ARM, ks_mode_arm;
+ KS_MODE_THUMB, ks_mode_thumb;
+ KS_MODE_V8, ks_mode_v8;
+ KS_MODE_MICRO, ks_mode_micro;
+ KS_MODE_MIPS3, ks_mode_mips3;
+ KS_MODE_MIPS32R6,ks_mode_mips32r6;
+ KS_MODE_MIPS32, ks_mode_mips32;
+ KS_MODE_MIPS64, ks_mode_mips64;
+ KS_MODE_16, ks_mode_16;
+ KS_MODE_32, ks_mode_32;
+ KS_MODE_64, ks_mode_64;
+ KS_MODE_PPC32, ks_mode_ppc32;
+ KS_MODE_PPC64, ks_mode_ppc64;
+ KS_MODE_QPX, ks_mode_qpx;
+ KS_MODE_SPARC32, ks_mode_sparc32;
+ KS_MODE_SPARC64, ks_mode_sparc64;
+ KS_MODE_V9, ks_mode_v9;
+ ]
+
+
+ type ks_opt_type =
+ | KS_OPT_SYNTAX
+
+ let ks_opt_syntax_ = constant "KS_OPT_SYNTAX" int64_t
+
+ let ks_opt_type = enum "ks_opt_type" [
+ KS_OPT_SYNTAX, ks_opt_syntax_;
+ ]
+
+ (** Runtime option value: refer to keystone.h for a full description *)
+ type ks_opt_value =
+ | KS_OPT_SYNTAX_INTEL
+ | KS_OPT_SYNTAX_ATT
+ | KS_OPT_SYNTAX_NASM
+ | KS_OPT_SYNTAX_MASM
+ | KS_OPT_SYNTAX_GAS
+
+
+ let ks_opt_syntax_intel = constant "KS_OPT_SYNTAX_INTEL" int64_t
+ let ks_opt_syntax_att = constant "KS_OPT_SYNTAX_ATT" int64_t
+ let ks_opt_syntax_nasm = constant "KS_OPT_SYNTAX_NASM" int64_t
+ let ks_opt_syntax_masm = constant "KS_OPT_SYNTAX_MASM" int64_t
+ let ks_opt_syntax_gas = constant "KS_OPT_SYNTAX_GAS" int64_t
+
+ let ks_opt_value = enum "ks_opt_value" [
+ KS_OPT_SYNTAX_INTEL, ks_opt_syntax_intel;
+ KS_OPT_SYNTAX_ATT, ks_opt_syntax_att;
+ KS_OPT_SYNTAX_NASM, ks_opt_syntax_nasm;
+ KS_OPT_SYNTAX_MASM, ks_opt_syntax_masm;
+ KS_OPT_SYNTAX_GAS, ks_opt_syntax_gas;
+ ]
+
+
+ module X86 =
+ struct
+ type ks_err_asm_x86 =
+ | KS_ERR_ASM_X86_INVALIDOPERAND
+ | KS_ERR_ASM_X86_MISSINGFEATURE
+ | KS_ERR_ASM_X86_MNEMONICFAIL
+
+ let ks_err_asm_x86_invalidoperand = constant "KS_ERR_ASM_X86_INVALIDOPERAND" int64_t
+ let ks_err_asm_x86_missingfeature = constant "KS_ERR_ASM_X86_MISSINGFEATURE" int64_t
+ let ks_err_asm_x86_mnemoicfail = constant "KS_ERR_ASM_X86_MNEMONICFAIL" int64_t
+
+ let ks_err_asm_x86 = enum "ks_err_asm_x86" [
+ KS_ERR_ASM_X86_INVALIDOPERAND, ks_err_asm_x86_invalidoperand;
+ KS_ERR_ASM_X86_MISSINGFEATURE, ks_err_asm_x86_missingfeature;
+ KS_ERR_ASM_X86_MNEMONICFAIL, ks_err_asm_x86_mnemoicfail;
+ ]
+ end
+
+ module ARM64 =
+ struct
+ type ks_err_asm_arm64 =
+ | KS_ERR_ASM_ARM64_INVALIDOPERAND
+ | KS_ERR_ASM_ARM64_MISSINGFEATURE
+ | KS_ERR_ASM_ARM64_MNEMONICFAIL
+
+
+ let ks_err_asm_arm64_invalidoperand = constant "KS_ERR_ASM_ARM64_INVALIDOPERAND" int64_t
+ let ks_err_asm_arm64_missingfeature = constant "KS_ERR_ASM_ARM64_MISSINGFEATURE" int64_t
+ let ks_err_asm_arm64_mnemonicfail = constant "KS_ERR_ASM_ARM64_MNEMONICFAIL" int64_t
+
+ let ks_err_asm_arm64 = enum "ks_err_asm_arm64" [
+ KS_ERR_ASM_ARM64_INVALIDOPERAND, ks_err_asm_arm64_invalidoperand;
+ KS_ERR_ASM_ARM64_MISSINGFEATURE, ks_err_asm_arm64_missingfeature;
+ KS_ERR_ASM_ARM64_MNEMONICFAIL, ks_err_asm_arm64_mnemonicfail;
+ ]
+ end
+
+ module ARM =
+ struct
+ type ks_err_asm_arm =
+ | KS_ERR_ASM_ARM_INVALIDOPERAND
+ | KS_ERR_ASM_ARM_MISSINGFEATURE
+ | KS_ERR_ASM_ARM_MNEMONICFAIL
+
+
+ let ks_err_asm_arm_invalidoperand = constant "KS_ERR_ASM_ARM_INVALIDOPERAND" int64_t
+ let ks_err_asm_arm_missingfeature = constant "KS_ERR_ASM_ARM_MISSINGFEATURE" int64_t
+ let ks_err_asm_arm_mnemonicfail = constant "KS_ERR_ASM_ARM_MNEMONICFAIL" int64_t
+
+ let ks_err_asm_arm = enum "ks_err_asm_arm" [
+ KS_ERR_ASM_ARM_INVALIDOPERAND, ks_err_asm_arm_invalidoperand;
+ KS_ERR_ASM_ARM_MISSINGFEATURE, ks_err_asm_arm_missingfeature;
+ KS_ERR_ASM_ARM_MNEMONICFAIL, ks_err_asm_arm_mnemonicfail;
+ ]
+ end
+
+ module HEXAGON =
+ struct
+ type ks_err_asm_hexagon =
+ | KS_ERR_ASM_HEXAGON_INVALIDOPERAND
+ | KS_ERR_ASM_HEXAGON_MISSINGFEATURE
+ | KS_ERR_ASM_HEXAGON_MNEMONICFAIL
+
+
+ let ks_err_asm_hexagon_invalidoperand = constant "KS_ERR_ASM_HEXAGON_INVALIDOPERAND" int64_t
+ let ks_err_asm_hexagon_missingfeature = constant "KS_ERR_ASM_HEXAGON_MISSINGFEATURE" int64_t
+ let ks_err_asm_hexagon_mnemonicfail = constant "KS_ERR_ASM_HEXAGON_MNEMONICFAIL" int64_t
+
+ let ks_err_asm_hexagon = enum "ks_err_asm_hexagon" [
+ KS_ERR_ASM_HEXAGON_INVALIDOPERAND, ks_err_asm_hexagon_invalidoperand;
+ KS_ERR_ASM_HEXAGON_MISSINGFEATURE, ks_err_asm_hexagon_missingfeature;
+ KS_ERR_ASM_HEXAGON_MNEMONICFAIL, ks_err_asm_hexagon_mnemonicfail;
+ ]
+ end
+
+
+ module MIPS =
+ struct
+ type ks_err_asm_mips =
+ | KS_ERR_ASM_MIPS_INVALIDOPERAND
+ | KS_ERR_ASM_MIPS_MISSINGFEATURE
+ | KS_ERR_ASM_MIPS_MNEMONICFAIL
+
+
+ let ks_err_asm_mips_invalidoperand = constant "KS_ERR_ASM_MIPS_INVALIDOPERAND" int64_t
+ let ks_err_asm_mips_missingfeature = constant "KS_ERR_ASM_MIPS_MISSINGFEATURE" int64_t
+ let ks_err_asm_mips_mnemonicfail = constant "KS_ERR_ASM_MIPS_MNEMONICFAIL" int64_t
+
+ let ks_err_asm_mips = enum "ks_err_asm_mips" [
+ KS_ERR_ASM_MIPS_INVALIDOPERAND, ks_err_asm_mips_invalidoperand;
+ KS_ERR_ASM_MIPS_MISSINGFEATURE, ks_err_asm_mips_missingfeature;
+ KS_ERR_ASM_MIPS_MNEMONICFAIL, ks_err_asm_mips_mnemonicfail;
+ ]
+ end
+
+
+
+ module PPC =
+ struct
+ type ks_err_asm_ppc =
+ | KS_ERR_ASM_PPC_INVALIDOPERAND
+ | KS_ERR_ASM_PPC_MISSINGFEATURE
+ | KS_ERR_ASM_PPC_MNEMONICFAIL
+
+
+ let ks_err_asm_ppc_invalidoperand = constant "KS_ERR_ASM_PPC_INVALIDOPERAND" int64_t
+ let ks_err_asm_ppc_missingfeature = constant "KS_ERR_ASM_PPC_MISSINGFEATURE" int64_t
+ let ks_err_asm_ppc_mnemonicfail = constant "KS_ERR_ASM_PPC_MNEMONICFAIL" int64_t
+
+ let ks_err_asm_ppc = enum "ks_err_asm_ppc" [
+ KS_ERR_ASM_PPC_INVALIDOPERAND, ks_err_asm_ppc_invalidoperand;
+ KS_ERR_ASM_PPC_MISSINGFEATURE, ks_err_asm_ppc_missingfeature;
+ KS_ERR_ASM_PPC_MNEMONICFAIL, ks_err_asm_ppc_mnemonicfail;
+ ]
+ end
+
+
+ module SPARC =
+ struct
+ type ks_err_asm_sparc =
+ | KS_ERR_ASM_SPARC_INVALIDOPERAND
+ | KS_ERR_ASM_SPARC_MISSINGFEATURE
+ | KS_ERR_ASM_SPARC_MNEMONICFAIL
+
+
+ let ks_err_asm_sparc_invalidoperand = constant "KS_ERR_ASM_SPARC_INVALIDOPERAND" int64_t
+ let ks_err_asm_sparc_missingfeature = constant "KS_ERR_ASM_SPARC_MISSINGFEATURE" int64_t
+ let ks_err_asm_sparc_mnemonicfail = constant "KS_ERR_ASM_SPARC_MNEMONICFAIL" int64_t
+
+ let ks_err_asm_sparc = enum "ks_err_asm_sparc" [
+ KS_ERR_ASM_SPARC_INVALIDOPERAND, ks_err_asm_sparc_invalidoperand;
+ KS_ERR_ASM_SPARC_MISSINGFEATURE, ks_err_asm_sparc_missingfeature;
+ KS_ERR_ASM_SPARC_MNEMONICFAIL, ks_err_asm_sparc_mnemonicfail;
+ ]
+ end
+
+ module SYSTEMZ =
+ struct
+ type ks_err_asm_systemz =
+ | KS_ERR_ASM_SYSTEMZ_INVALIDOPERAND
+ | KS_ERR_ASM_SYSTEMZ_MISSINGFEATURE
+ | KS_ERR_ASM_SYSTEMZ_MNEMONICFAIL
+
+
+ let ks_err_asm_systemz_invalidoperand = constant "KS_ERR_ASM_SYSTEMZ_INVALIDOPERAND" int64_t
+ let ks_err_asm_systemz_missingfeature = constant "KS_ERR_ASM_SYSTEMZ_MISSINGFEATURE" int64_t
+ let ks_err_asm_systemz_mnemonicfail = constant "KS_ERR_ASM_SYSTEMZ_MNEMONICFAIL" int64_t
+
+ let ks_err_asm_systemz = enum "ks_err_asm_systemz" [
+ KS_ERR_ASM_SYSTEMZ_INVALIDOPERAND, ks_err_asm_systemz_invalidoperand;
+ KS_ERR_ASM_SYSTEMZ_MISSINGFEATURE, ks_err_asm_systemz_missingfeature;
+ KS_ERR_ASM_SYSTEMZ_MNEMONICFAIL, ks_err_asm_systemz_mnemonicfail;
+ ]
+ end
+
+
+
+
+
+
+
+ end
diff --git a/bindings/ocaml/ffi_types_stubgen.ml b/bindings/ocaml/ffi_types_stubgen.ml
new file mode 100644
index 0000000000000000000000000000000000000000..76a0f66b99feadd8e0fe0bcce6bbf7221b7e7d9d
--- /dev/null
+++ b/bindings/ocaml/ffi_types_stubgen.ml
@@ -0,0 +1,3 @@
+let () =
+ print_endline ("#include " ^ Config.keystone_header_loc);
+ Cstubs.Types.write_c Format.std_formatter (module Ffi_types.Types)
diff --git a/bindings/ocaml/keystone.ml b/bindings/ocaml/keystone.ml
new file mode 100644
index 0000000000000000000000000000000000000000..a64af868d85ee2d66aa794f53c91e0f4d78a86a2
--- /dev/null
+++ b/bindings/ocaml/keystone.ml
@@ -0,0 +1,82 @@
+open Ctypes
+open Foreign
+
+module B = Ffi_bindings.Bindings(Ffi_generated)
+module Types = B.T
+
+type encoded_result =
+ {
+ encoding: int array;
+ encoding_size : int;
+ stat_count : int;
+ }
+
+let ks_arch_supported arch =
+ B.ks_arch_supported_ arch
+
+let ks_version major minor =
+ let major = Unsigned.UInt.of_int major in
+ let minor = Unsigned.UInt.of_int minor in
+ let u = B.ks_version_ (allocate uint major) (allocate uint minor) in
+ Unsigned.UInt.to_int u
+
+(* TODO: better handling of error value *)
+let ks_option engine opttype optvalue =
+ match opttype with
+ | Types.KS_OPT_SYNTAX -> B.ks_option_ engine Types.KS_OPT_SYNTAX optvalue
+
+let ks_strerror err =
+ B.ks_strerror_ err
+
+let ks_open arch ?(endian=Types.KS_MODE_LITTLE_ENDIAN) mode =
+ let check_endian =
+ match endian with
+ | Types.KS_MODE_BIG_ENDIAN ->
+ begin
+ let m = Ffi_generated_types.constant (Types.string_of_ks_mode Types.KS_MODE_BIG_ENDIAN) int64_t in
+ let m' = Ffi_generated_types.constant (Types.string_of_ks_mode mode) int64_t in
+ Result.Ok(Int64.add m m')
+
+ end
+ | Types.KS_MODE_LITTLE_ENDIAN -> Result.Ok(Ffi_generated_types.constant (Types.string_of_ks_mode mode) int64_t)
+ | _ -> Result.Error("Non-endian mode passed to endian arg of ks_open: use KS_MODE_BIG_ENDIAN or KS_MODE_LITTLE_ENDIAN")
+ in
+ let mode =
+ match check_endian with
+ | Result.Ok a -> a
+ | Result.Error e -> failwith e
+ in
+ let engine = allocate_n ~count:1 ((ptr Types.ks_engine)) in
+
+ match (B.ks_open_ arch mode engine) with
+ | Types.KS_ERR_OK -> Result.Ok(!@ engine)
+ | _ as err -> Result.Error(ks_strerror err)
+
+
+let ks_close engine = B.ks_close_ engine
+
+let ks_errno engine = B.ks_err_ engine
+
+
+let ks_asm engine str addr =
+ let addr' = Int64.of_int addr in
+ let encoding = allocate_n ~count:1 (ptr uchar) in
+ let encoding_size = allocate size_t (Unsigned.Size_t.of_int 0) in
+ let stat_count = allocate size_t (Unsigned.Size_t.of_int 0) in
+ match (B.ks_asm_ engine str addr' encoding encoding_size stat_count) with
+ | 0 -> begin
+ let iencoding_size = Unsigned.Size_t.to_int (!@ encoding_size) in
+ let istat_count = Unsigned.Size_t.to_int (!@ stat_count) in
+ let encodedasm =
+ CArray.from_ptr (!@ encoding) (Unsigned.Size_t.to_int (!@ encoding_size))
+ |> CArray.to_list |> Array.of_list (* No map in CArray *)
+ |> Array.map (fun c -> Unsigned.UChar.to_int c)
+ in
+ B.ks_free_ (to_voidp (!@ encoding));
+ Result.Ok({encoding = encodedasm; encoding_size = iencoding_size; stat_count = istat_count})
+ end
+ | _ -> let err = ks_errno engine |> ks_strerror in
+ Result.Error err
+
+let asm_array_to_string a =
+ Array.fold_left (fun str c -> let t = Printf.sprintf "%02x " c in str^t) "" a
diff --git a/bindings/ocaml/keystone.mldylib b/bindings/ocaml/keystone.mldylib
new file mode 100644
index 0000000000000000000000000000000000000000..b6dd06f8400a39c5abcfed5cf369519f649455e1
--- /dev/null
+++ b/bindings/ocaml/keystone.mldylib
@@ -0,0 +1,8 @@
+# OASIS_START
+# DO NOT EDIT (digest: 245ae3e4b1018fbf4a40ba68d8f67205)
+Keystone
+Ffi_generated
+Ffi_types
+Ffi_bindings
+Ffi_generated_types
+# OASIS_STOP
diff --git a/bindings/ocaml/keystone.mli b/bindings/ocaml/keystone.mli
new file mode 100644
index 0000000000000000000000000000000000000000..4fdb255550499228278db9a14850f98727314a7e
--- /dev/null
+++ b/bindings/ocaml/keystone.mli
@@ -0,0 +1,165 @@
+(** Module proving OCaml bindings to the Keystone assembler engine *)
+
+
+module Types : sig
+ (** Type definitions for Keystone *)
+
+ (** Keystone engine type *)
+ type ks_t
+
+ (** Keystone Architecture. Please see keystone.h for a full description. *)
+ type ks_arch =
+ | KS_ARCH_ARM
+ | KS_ARCH_ARM64
+ | KS_ARCH_MIPS
+ | KS_ARCH_X86
+ | KS_ARCH_PPC
+ | KS_ARCH_SPARC
+ | KS_ARCH_SYSTEMZ
+ | KS_ARCH_HEXAGON
+ | KS_ARCH_MAX
+
+ (** Keystone error types. Please see keystone.h for a full description. *)
+ type ks_error =
+ | KS_ERR_OK
+ | KS_ERR_NOMEM
+ | KS_ERR_ARCH
+ | KS_ERR_HANDLE
+ | KS_ERR_MODE
+ | KS_ERR_VERSION
+ | KS_ERR_OPT_INVALID
+ | KS_ERR_ASM_EXPR_TOKEN
+ | KS_ERR_ASM_DIRECTIVE_VALUE_RANGE
+ | KS_ERR_ASM_DIRECTIVE_ID
+ | KS_ERR_ASM_DIRECTIVE_TOKEN
+ | KS_ERR_ASM_DIRECTIVE_STR
+ | KS_ERR_ASM_DIRECTIVE_COMMA
+ | KS_ERR_ASM_DIRECTIVE_RELOC_NAME
+ | KS_ERR_ASM_DIRECTIVE_RELOC_TOKEN
+ | KS_ERR_ASM_DIRECTIVE_FPOINT
+ | KS_ERR_ASM_DIRECTIVE_UNKNOWN
+ | KS_ERR_ASM_VARIANT_INVALID
+ | KS_ERR_ASM_DIRECTIVE_EQU
+ | KS_ERR_ASM_EXPR_BRACKET
+ | KS_ERR_ASM_SYMBOL_MODIFIER
+ | KS_ERR_ASM_SYMBOL_REDEFINED
+ | KS_ERR_ASM_SYMBOL_MISSING
+ | KS_ERR_ASM_RPAREN
+ | KS_ERR_ASM_STAT_TOKEN
+ | KS_ERR_ASM_UNSUPPORTED
+ | KS_ERR_ASM_MACRO_TOKEN
+ | KS_ERR_ASM_MACRO_PAREN
+ | KS_ERR_ASM_MACRO_EQU
+ | KS_ERR_ASM_MACRO_ARGS
+ | KS_ERR_ASM_MACRO_LEVELS_EXCEED
+ | KS_ERR_ASM_MACRO_STR
+ | KS_ERR_ASM_ESC_BACKSLASH
+ | KS_ERR_ASM_ESC_OCTAL
+ | KS_ERR_ASM_ESC_SEQUENCE
+ | KS_ERR_ASM_ESC_STR
+ | KS_ERR_ASM_TOKEN_INVALID
+ | KS_ERR_ASM_INSN_UNSUPPORTED
+ | KS_ERR_ASM_FIXUP_INVALID
+ | KS_ERR_ASM_LABEL_INVALID
+ | KS_ERR_ASM_FRAGMENT_INVALID
+ | KS_ERR_ASM_INVALIDOPERAND
+ | KS_ERR_ASM_MISSINGFEATURE
+ | KS_ERR_ASM_MNEMONICFAIL
+
+ type ks_opt_type =
+ | KS_OPT_SYNTAX
+
+ type ks_opt_value =
+ | KS_OPT_SYNTAX_INTEL
+ | KS_OPT_SYNTAX_ATT
+ | KS_OPT_SYNTAX_NASM
+ | KS_OPT_SYNTAX_MASM
+ | KS_OPT_SYNTAX_GAS
+
+ type ks_mode =
+ | KS_MODE_ARM
+ | KS_MODE_BIG_ENDIAN
+ | KS_MODE_LITTLE_ENDIAN
+ | KS_MODE_THUMB
+ | KS_MODE_V8
+ | KS_MODE_MICRO
+ | KS_MODE_MIPS3
+ | KS_MODE_MIPS32R6
+ | KS_MODE_MIPS32
+ | KS_MODE_MIPS64
+ | KS_MODE_16
+ | KS_MODE_32
+ | KS_MODE_64
+ | KS_MODE_PPC32
+ | KS_MODE_PPC64
+ | KS_MODE_QPX
+ | KS_MODE_SPARC32
+ | KS_MODE_SPARC64
+ | KS_MODE_V9
+end
+
+(** Record containing a successful encoding result.
+ encoding field contains an int array
+ encoding_size is size of the encoding
+ stat_count records how many statements were successfully processed.
+*)
+type encoded_result =
+ {
+ encoding: int array;
+ encoding_size : int;
+ stat_count : int;
+ }
+
+(** Determine if the given architecture is supported. True if the
+ architecture is supported, false otherwise *)
+val ks_arch_supported : Types.ks_arch -> bool
+
+val ks_version : int -> int -> int
+
+
+(** Set an option for a Keystone engine instance.
+ Takes an engine instance, an option type and an option value.
+
+ Returns KS_ERR_OK on success or another value on failure.
+*)
+val ks_option :
+ Types.ks_t ->
+ Types.ks_opt_type -> Types.ks_opt_value -> Types.ks_error
+
+(** Given a ks_err type, returns a string description of the error. *)
+val ks_strerror : Types.ks_error -> string
+
+
+
+(** Create a new instance of Keystone engine.
+ arch: is architecture type, mode is hardware mode.
+
+ Returns a Keystone engine or a string with an error message.
+*)
+val ks_open :
+ Types.ks_arch -> ?endian:Types.ks_mode -> Types.ks_mode -> (Types.ks_t, string) Result.result
+
+
+
+(** Close the Keystone engine instance *)
+val ks_close : Types.ks_t -> int64
+
+
+(** Given a Keystone engine instance, returns the last error number on
+ some API function failure. *)
+val ks_errno :
+ Types.ks_t -> Types.ks_error
+
+
+(** Assemble a string: takes a Keystone engine instance, a string to
+assemble and a start address to assemble from.
+
+On success returns Ok with a encoded_result record
+ *)
+val ks_asm :
+ Types.ks_t ->
+ string -> int -> (encoded_result, string) Result.result
+
+(** Convert an array containing an encoding of an assembly string and
+returns a string representation. *)
+val asm_array_to_string : int array -> string
diff --git a/bindings/ocaml/keystone.mllib b/bindings/ocaml/keystone.mllib
new file mode 100644
index 0000000000000000000000000000000000000000..b6dd06f8400a39c5abcfed5cf369519f649455e1
--- /dev/null
+++ b/bindings/ocaml/keystone.mllib
@@ -0,0 +1,8 @@
+# OASIS_START
+# DO NOT EDIT (digest: 245ae3e4b1018fbf4a40ba68d8f67205)
+Keystone
+Ffi_generated
+Ffi_types
+Ffi_bindings
+Ffi_generated_types
+# OASIS_STOP
diff --git a/bindings/ocaml/keystone.odocl b/bindings/ocaml/keystone.odocl
new file mode 100644
index 0000000000000000000000000000000000000000..b6dd06f8400a39c5abcfed5cf369519f649455e1
--- /dev/null
+++ b/bindings/ocaml/keystone.odocl
@@ -0,0 +1,8 @@
+# OASIS_START
+# DO NOT EDIT (digest: 245ae3e4b1018fbf4a40ba68d8f67205)
+Keystone
+Ffi_generated
+Ffi_types
+Ffi_bindings
+Ffi_generated_types
+# OASIS_STOP
diff --git a/bindings/ocaml/keystone_bindings.mldylib b/bindings/ocaml/keystone_bindings.mldylib
new file mode 100644
index 0000000000000000000000000000000000000000..7c49c4c711a1d3ef1f8142c6fc7dd15402114eef
--- /dev/null
+++ b/bindings/ocaml/keystone_bindings.mldylib
@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: b0cb983199f14176130ec534492d2489)
+Ffi_bindings
+# OASIS_STOP
diff --git a/bindings/ocaml/keystone_bindings.mllib b/bindings/ocaml/keystone_bindings.mllib
new file mode 100644
index 0000000000000000000000000000000000000000..7c49c4c711a1d3ef1f8142c6fc7dd15402114eef
--- /dev/null
+++ b/bindings/ocaml/keystone_bindings.mllib
@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: b0cb983199f14176130ec534492d2489)
+Ffi_bindings
+# OASIS_STOP
diff --git a/bindings/ocaml/keystone_types.mldylib b/bindings/ocaml/keystone_types.mldylib
new file mode 100644
index 0000000000000000000000000000000000000000..be6d9175588eb9a9966df4cfae150fb3b637fec3
--- /dev/null
+++ b/bindings/ocaml/keystone_types.mldylib
@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: e3b57ef8f44642217053313131298e86)
+Ffi_types
+# OASIS_STOP
diff --git a/bindings/ocaml/keystone_types.mllib b/bindings/ocaml/keystone_types.mllib
new file mode 100644
index 0000000000000000000000000000000000000000..be6d9175588eb9a9966df4cfae150fb3b637fec3
--- /dev/null
+++ b/bindings/ocaml/keystone_types.mllib
@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: e3b57ef8f44642217053313131298e86)
+Ffi_types
+# OASIS_STOP
diff --git a/bindings/ocaml/libkeystone_stubs.clib b/bindings/ocaml/libkeystone_stubs.clib
new file mode 100644
index 0000000000000000000000000000000000000000..a27758ff5dde941fabb6ea72907f87e3e4e5db50
--- /dev/null
+++ b/bindings/ocaml/libkeystone_stubs.clib
@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: d7517d65f92f5a924cbb6dcbdb6589a1)
+ffi_generated_stubs.o
+# OASIS_STOP
diff --git a/bindings/ocaml/myocamlbuild.ml b/bindings/ocaml/myocamlbuild.ml
new file mode 100644
index 0000000000000000000000000000000000000000..8664be23b7e5d94bd16137d3ae087f8c114f4b9e
--- /dev/null
+++ b/bindings/ocaml/myocamlbuild.ml
@@ -0,0 +1,847 @@
+(* OASIS_START *)
+(* DO NOT EDIT (digest: 31a38f4659c6e259b7a0fa94012983de) *)
+module OASISGettext = struct
+(* # 22 "src/oasis/OASISGettext.ml" *)
+
+
+ let ns_ str =
+ str
+
+
+ let s_ str =
+ str
+
+
+ let f_ (str: ('a, 'b, 'c, 'd) format4) =
+ str
+
+
+ let fn_ fmt1 fmt2 n =
+ if n = 1 then
+ fmt1^^""
+ else
+ fmt2^^""
+
+
+ let init =
+ []
+
+
+end
+
+module OASISString = struct
+(* # 22 "src/oasis/OASISString.ml" *)
+
+
+ (** Various string utilities.
+
+ Mostly inspired by extlib and batteries ExtString and BatString libraries.
+
+ @author Sylvain Le Gall
+ *)
+
+
+ let nsplitf str f =
+ if str = "" then
+ []
+ else
+ let buf = Buffer.create 13 in
+ let lst = ref [] in
+ let push () =
+ lst := Buffer.contents buf :: !lst;
+ Buffer.clear buf
+ in
+ let str_len = String.length str in
+ for i = 0 to str_len - 1 do
+ if f str.[i] then
+ push ()
+ else
+ Buffer.add_char buf str.[i]
+ done;
+ push ();
+ List.rev !lst
+
+
+ (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
+ separator.
+ *)
+ let nsplit str c =
+ nsplitf str ((=) c)
+
+
+ let find ~what ?(offset=0) str =
+ let what_idx = ref 0 in
+ let str_idx = ref offset in
+ while !str_idx < String.length str &&
+ !what_idx < String.length what do
+ if str.[!str_idx] = what.[!what_idx] then
+ incr what_idx
+ else
+ what_idx := 0;
+ incr str_idx
+ done;
+ if !what_idx <> String.length what then
+ raise Not_found
+ else
+ !str_idx - !what_idx
+
+
+ let sub_start str len =
+ let str_len = String.length str in
+ if len >= str_len then
+ ""
+ else
+ String.sub str len (str_len - len)
+
+
+ let sub_end ?(offset=0) str len =
+ let str_len = String.length str in
+ if len >= str_len then
+ ""
+ else
+ String.sub str 0 (str_len - len)
+
+
+ let starts_with ~what ?(offset=0) str =
+ let what_idx = ref 0 in
+ let str_idx = ref offset in
+ let ok = ref true in
+ while !ok &&
+ !str_idx < String.length str &&
+ !what_idx < String.length what do
+ if str.[!str_idx] = what.[!what_idx] then
+ incr what_idx
+ else
+ ok := false;
+ incr str_idx
+ done;
+ if !what_idx = String.length what then
+ true
+ else
+ false
+
+
+ let strip_starts_with ~what str =
+ if starts_with ~what str then
+ sub_start str (String.length what)
+ else
+ raise Not_found
+
+
+ let ends_with ~what ?(offset=0) str =
+ let what_idx = ref ((String.length what) - 1) in
+ let str_idx = ref ((String.length str) - 1) in
+ let ok = ref true in
+ while !ok &&
+ offset <= !str_idx &&
+ 0 <= !what_idx do
+ if str.[!str_idx] = what.[!what_idx] then
+ decr what_idx
+ else
+ ok := false;
+ decr str_idx
+ done;
+ if !what_idx = -1 then
+ true
+ else
+ false
+
+
+ let strip_ends_with ~what str =
+ if ends_with ~what str then
+ sub_end str (String.length what)
+ else
+ raise Not_found
+
+
+ let replace_chars f s =
+ let buf = Buffer.create (String.length s) in
+ String.iter (fun c -> Buffer.add_char buf (f c)) s;
+ Buffer.contents buf
+
+ let lowercase_ascii =
+ replace_chars
+ (fun c ->
+ if (c >= 'A' && c <= 'Z') then
+ Char.chr (Char.code c + 32)
+ else
+ c)
+
+ let uncapitalize_ascii s =
+ if s <> "" then
+ (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
+ else
+ s
+
+ let uppercase_ascii =
+ replace_chars
+ (fun c ->
+ if (c >= 'a' && c <= 'z') then
+ Char.chr (Char.code c - 32)
+ else
+ c)
+
+ let capitalize_ascii s =
+ if s <> "" then
+ (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
+ else
+ s
+
+end
+
+module OASISExpr = struct
+(* # 22 "src/oasis/OASISExpr.ml" *)
+
+
+
+
+
+ open OASISGettext
+
+
+ type test = string
+
+
+ type flag = string
+
+
+ type t =
+ | EBool of bool
+ | ENot of t
+ | EAnd of t * t
+ | EOr of t * t
+ | EFlag of flag
+ | ETest of test * string
+
+
+
+ type 'a choices = (t * 'a) list
+
+
+ let eval var_get t =
+ let rec eval' =
+ function
+ | EBool b ->
+ b
+
+ | ENot e ->
+ not (eval' e)
+
+ | EAnd (e1, e2) ->
+ (eval' e1) && (eval' e2)
+
+ | EOr (e1, e2) ->
+ (eval' e1) || (eval' e2)
+
+ | EFlag nm ->
+ let v =
+ var_get nm
+ in
+ assert(v = "true" || v = "false");
+ (v = "true")
+
+ | ETest (nm, vl) ->
+ let v =
+ var_get nm
+ in
+ (v = vl)
+ in
+ eval' t
+
+
+ let choose ?printer ?name var_get lst =
+ let rec choose_aux =
+ function
+ | (cond, vl) :: tl ->
+ if eval var_get cond then
+ vl
+ else
+ choose_aux tl
+ | [] ->
+ let str_lst =
+ if lst = [] then
+ s_ "<empty>"
+ else
+ String.concat
+ (s_ ", ")
+ (List.map
+ (fun (cond, vl) ->
+ match printer with
+ | Some p -> p vl
+ | None -> s_ "<no printer>")
+ lst)
+ in
+ match name with
+ | Some nm ->
+ failwith
+ (Printf.sprintf
+ (f_ "No result for the choice list '%s': %s")
+ nm str_lst)
+ | None ->
+ failwith
+ (Printf.sprintf
+ (f_ "No result for a choice list: %s")
+ str_lst)
+ in
+ choose_aux (List.rev lst)
+
+
+end
+
+
+# 292 "myocamlbuild.ml"
+module BaseEnvLight = struct
+(* # 22 "src/base/BaseEnvLight.ml" *)
+
+
+ module MapString = Map.Make(String)
+
+
+ type t = string MapString.t
+
+
+ let default_filename =
+ Filename.concat
+ (Sys.getcwd ())
+ "setup.data"
+
+
+ let load ?(allow_empty=false) ?(filename=default_filename) () =
+ if Sys.file_exists filename then
+ begin
+ let chn =
+ open_in_bin filename
+ in
+ let st =
+ Stream.of_channel chn
+ in
+ let line =
+ ref 1
+ in
+ let st_line =
+ Stream.from
+ (fun _ ->
+ try
+ match Stream.next st with
+ | '\n' -> incr line; Some '\n'
+ | c -> Some c
+ with Stream.Failure -> None)
+ in
+ let lexer =
+ Genlex.make_lexer ["="] st_line
+ in
+ let rec read_file mp =
+ match Stream.npeek 3 lexer with
+ | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
+ Stream.junk lexer;
+ Stream.junk lexer;
+ Stream.junk lexer;
+ read_file (MapString.add nm value mp)
+ | [] ->
+ mp
+ | _ ->
+ failwith
+ (Printf.sprintf
+ "Malformed data file '%s' line %d"
+ filename !line)
+ in
+ let mp =
+ read_file MapString.empty
+ in
+ close_in chn;
+ mp
+ end
+ else if allow_empty then
+ begin
+ MapString.empty
+ end
+ else
+ begin
+ failwith
+ (Printf.sprintf
+ "Unable to load environment, the file '%s' doesn't exist."
+ filename)
+ end
+
+
+ let rec var_expand str env =
+ let buff =
+ Buffer.create ((String.length str) * 2)
+ in
+ Buffer.add_substitute
+ buff
+ (fun var ->
+ try
+ var_expand (MapString.find var env) env
+ with Not_found ->
+ failwith
+ (Printf.sprintf
+ "No variable %s defined when trying to expand %S."
+ var
+ str))
+ str;
+ Buffer.contents buff
+
+
+ let var_get name env =
+ var_expand (MapString.find name env) env
+
+
+ let var_choose lst env =
+ OASISExpr.choose
+ (fun nm -> var_get nm env)
+ lst
+end
+
+
+# 397 "myocamlbuild.ml"
+module MyOCamlbuildFindlib = struct
+(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *)
+
+
+ (** OCamlbuild extension, copied from
+ * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild
+ * by N. Pouillard and others
+ *
+ * Updated on 2009/02/28
+ *
+ * Modified by Sylvain Le Gall
+ *)
+ open Ocamlbuild_plugin
+
+ type conf =
+ { no_automatic_syntax: bool;
+ }
+
+ (* these functions are not really officially exported *)
+ let run_and_read =
+ Ocamlbuild_pack.My_unix.run_and_read
+
+
+ let blank_sep_strings =
+ Ocamlbuild_pack.Lexers.blank_sep_strings
+
+
+ let exec_from_conf exec =
+ let exec =
+ let env_filename = Pathname.basename BaseEnvLight.default_filename in
+ let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in
+ try
+ BaseEnvLight.var_get exec env
+ with Not_found ->
+ Printf.eprintf "W: Cannot get variable %s\n" exec;
+ exec
+ in
+ let fix_win32 str =
+ if Sys.os_type = "Win32" then begin
+ let buff = Buffer.create (String.length str) in
+ (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'.
+ *)
+ String.iter
+ (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c))
+ str;
+ Buffer.contents buff
+ end else begin
+ str
+ end
+ in
+ fix_win32 exec
+
+ let split s ch =
+ let buf = Buffer.create 13 in
+ let x = ref [] in
+ let flush () =
+ x := (Buffer.contents buf) :: !x;
+ Buffer.clear buf
+ in
+ String.iter
+ (fun c ->
+ if c = ch then
+ flush ()
+ else
+ Buffer.add_char buf c)
+ s;
+ flush ();
+ List.rev !x
+
+
+ let split_nl s = split s '\n'
+
+
+ let before_space s =
+ try
+ String.before s (String.index s ' ')
+ with Not_found -> s
+
+ (* ocamlfind command *)
+ let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x]
+
+ (* This lists all supported packages. *)
+ let find_packages () =
+ List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list"))
+
+
+ (* Mock to list available syntaxes. *)
+ let find_syntaxes () = ["camlp4o"; "camlp4r"]
+
+
+ let well_known_syntax = [
+ "camlp4.quotations.o";
+ "camlp4.quotations.r";
+ "camlp4.exceptiontracer";
+ "camlp4.extend";
+ "camlp4.foldgenerator";
+ "camlp4.listcomprehension";
+ "camlp4.locationstripper";
+ "camlp4.macro";
+ "camlp4.mapgenerator";
+ "camlp4.metagenerator";
+ "camlp4.profiler";
+ "camlp4.tracer"
+ ]
+
+
+ let dispatch conf =
+ function
+ | After_options ->
+ (* By using Before_options one let command line options have an higher
+ * priority on the contrary using After_options will guarantee to have
+ * the higher priority override default commands by ocamlfind ones *)
+ Options.ocamlc := ocamlfind & A"ocamlc";
+ Options.ocamlopt := ocamlfind & A"ocamlopt";
+ Options.ocamldep := ocamlfind & A"ocamldep";
+ Options.ocamldoc := ocamlfind & A"ocamldoc";
+ Options.ocamlmktop := ocamlfind & A"ocamlmktop";
+ Options.ocamlmklib := ocamlfind & A"ocamlmklib"
+
+ | After_rules ->
+
+ (* When one link an OCaml library/binary/package, one should use
+ * -linkpkg *)
+ flag ["ocaml"; "link"; "program"] & A"-linkpkg";
+
+ if not (conf.no_automatic_syntax) then begin
+ (* For each ocamlfind package one inject the -package option when
+ * compiling, computing dependencies, generating documentation and
+ * linking. *)
+ List.iter
+ begin fun pkg ->
+ let base_args = [A"-package"; A pkg] in
+ (* TODO: consider how to really choose camlp4o or camlp4r. *)
+ let syn_args = [A"-syntax"; A "camlp4o"] in
+ let (args, pargs) =
+ (* Heuristic to identify syntax extensions: whether they end in
+ ".syntax"; some might not.
+ *)
+ if Filename.check_suffix pkg "syntax" ||
+ List.mem pkg well_known_syntax then
+ (syn_args @ base_args, syn_args)
+ else
+ (base_args, [])
+ in
+ flag ["ocaml"; "compile"; "pkg_"^pkg] & S args;
+ flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args;
+ flag ["ocaml"; "doc"; "pkg_"^pkg] & S args;
+ flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args;
+ flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args;
+
+ (* TODO: Check if this is allowed for OCaml < 3.12.1 *)
+ flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs;
+ flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs;
+ flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs;
+ flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs;
+ end
+ (find_packages ());
+ end;
+
+ (* Like -package but for extensions syntax. Morover -syntax is useless
+ * when linking. *)
+ List.iter begin fun syntax ->
+ flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+ flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+ flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax];
+ flag ["ocaml"; "infer_interface"; "syntax_"^syntax] &
+ S[A"-syntax"; A syntax];
+ end (find_syntaxes ());
+
+ (* The default "thread" tag is not compatible with ocamlfind.
+ * Indeed, the default rules add the "threads.cma" or "threads.cmxa"
+ * options when using this tag. When using the "-linkpkg" option with
+ * ocamlfind, this module will then be added twice on the command line.
+ *
+ * To solve this, one approach is to add the "-thread" option when using
+ * the "threads" package using the previous plugin.
+ *)
+ flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]);
+ flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]);
+ flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]);
+ flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]);
+ flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]);
+ flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]);
+ flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]);
+ flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]);
+
+ | _ ->
+ ()
+end
+
+module MyOCamlbuildBase = struct
+(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
+
+
+ (** Base functions for writing myocamlbuild.ml
+ @author Sylvain Le Gall
+ *)
+
+
+
+
+
+ open Ocamlbuild_plugin
+ module OC = Ocamlbuild_pack.Ocaml_compiler
+
+
+ type dir = string
+ type file = string
+ type name = string
+ type tag = string
+
+
+(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
+
+
+ type t =
+ {
+ lib_ocaml: (name * dir list * string list) list;
+ lib_c: (name * dir * file list) list;
+ flags: (tag list * (spec OASISExpr.choices)) list;
+ (* Replace the 'dir: include' from _tags by a precise interdepends in
+ * directory.
+ *)
+ includes: (dir * dir list) list;
+ }
+
+
+ let env_filename =
+ Pathname.basename
+ BaseEnvLight.default_filename
+
+
+ let dispatch_combine lst =
+ fun e ->
+ List.iter
+ (fun dispatch -> dispatch e)
+ lst
+
+
+ let tag_libstubs nm =
+ "use_lib"^nm^"_stubs"
+
+
+ let nm_libstubs nm =
+ nm^"_stubs"
+
+
+ let dispatch t e =
+ let env =
+ BaseEnvLight.load
+ ~filename:env_filename
+ ~allow_empty:true
+ ()
+ in
+ match e with
+ | Before_options ->
+ let no_trailing_dot s =
+ if String.length s >= 1 && s.[0] = '.' then
+ String.sub s 1 ((String.length s) - 1)
+ else
+ s
+ in
+ List.iter
+ (fun (opt, var) ->
+ try
+ opt := no_trailing_dot (BaseEnvLight.var_get var env)
+ with Not_found ->
+ Printf.eprintf "W: Cannot get variable %s\n" var)
+ [
+ Options.ext_obj, "ext_obj";
+ Options.ext_lib, "ext_lib";
+ Options.ext_dll, "ext_dll";
+ ]
+
+ | After_rules ->
+ (* Declare OCaml libraries *)
+ List.iter
+ (function
+ | nm, [], intf_modules ->
+ ocaml_lib nm;
+ let cmis =
+ List.map (fun m -> (OASISString.uncapitalize_ascii m) ^ ".cmi")
+ intf_modules in
+ dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis
+ | nm, dir :: tl, intf_modules ->
+ ocaml_lib ~dir:dir (dir^"/"^nm);
+ List.iter
+ (fun dir ->
+ List.iter
+ (fun str ->
+ flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir]))
+ ["compile"; "infer_interface"; "doc"])
+ tl;
+ let cmis =
+ List.map (fun m -> dir^"/"^(OASISString.uncapitalize_ascii m)^".cmi")
+ intf_modules in
+ dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"]
+ cmis)
+ t.lib_ocaml;
+
+ (* Declare directories dependencies, replace "include" in _tags. *)
+ List.iter
+ (fun (dir, include_dirs) ->
+ Pathname.define_context dir include_dirs)
+ t.includes;
+
+ (* Declare C libraries *)
+ List.iter
+ (fun (lib, dir, headers) ->
+ (* Handle C part of library *)
+ flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib]
+ (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib";
+ A("-l"^(nm_libstubs lib))]);
+
+ flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib]
+ (S[A"-cclib"; A("-l"^(nm_libstubs lib))]);
+
+ flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib]
+ (S[A"-dllib"; A("dll"^(nm_libstubs lib))]);
+
+ (* When ocaml link something that use the C library, then one
+ need that file to be up to date.
+ This holds both for programs and for libraries.
+ *)
+ dep ["link"; "ocaml"; tag_libstubs lib]
+ [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
+
+ dep ["compile"; "ocaml"; tag_libstubs lib]
+ [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
+
+ (* TODO: be more specific about what depends on headers *)
+ (* Depends on .h files *)
+ dep ["compile"; "c"]
+ headers;
+
+ (* Setup search path for lib *)
+ flag ["link"; "ocaml"; "use_"^lib]
+ (S[A"-I"; P(dir)]);
+ )
+ t.lib_c;
+
+ (* Add flags *)
+ List.iter
+ (fun (tags, cond_specs) ->
+ let spec = BaseEnvLight.var_choose cond_specs env in
+ let rec eval_specs =
+ function
+ | S lst -> S (List.map eval_specs lst)
+ | A str -> A (BaseEnvLight.var_expand str env)
+ | spec -> spec
+ in
+ flag tags & (eval_specs spec))
+ t.flags
+ | _ ->
+ ()
+
+
+ let dispatch_default conf t =
+ dispatch_combine
+ [
+ dispatch t;
+ MyOCamlbuildFindlib.dispatch conf;
+ ]
+
+
+end
+
+
+# 766 "myocamlbuild.ml"
+open Ocamlbuild_plugin;;
+let package_default =
+ {
+ MyOCamlbuildBase.lib_ocaml = [("keystone", [], [])];
+ lib_c = [("keystone", ".", [])];
+ flags =
+ [
+ (["oasis_library_keystone_ccopt"; "compile"],
+ [
+ (OASISExpr.EBool true,
+ S [A "-ccopt"; A "-I"; A "-ccopt"; A "${pkg_ctypes_stubs}"])
+ ]);
+ (["oasis_library_keystone_cclib"; "link"],
+ [(OASISExpr.EBool true, S [A "-cclib"; A "-lkeystone"])]);
+ (["oasis_library_keystone_cclib"; "ocamlmklib"; "c"],
+ [(OASISExpr.EBool true, S [A "-lkeystone"])]);
+ (["oasis_executable_test_bindings_cclib"; "link"],
+ [(OASISExpr.EBool true, S [A "-cclib"; A "-lkeystone"])]);
+ (["oasis_executable_test_bindings_cclib"; "ocamlmklib"; "c"],
+ [(OASISExpr.EBool true, S [A "-lkeystone"])])
+ ];
+ includes = []
+ }
+ ;;
+
+let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false}
+
+let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;;
+
+# 797 "myocamlbuild.ml"
+(* OASIS_STOP *)
+Ocamlbuild_plugin.dispatch dispatch_default;;
+let dispatch = function
+ | After_rules ->
+ let stubgen = "ffi_stubgen.native" in
+ let stubgen_types = "ffi_types_stubgen.native" in
+ let stubgen_ml_types = "ffi_ml_types_stubgen.native" in
+
+ rule "generated-types ml"
+ ~dep:stubgen_ml_types
+ ~prod:"ffi_generated_types.ml"
+ (fun _ _ ->
+ Cmd (S [P ("./" ^ stubgen_ml_types); Sh">>"; A"ffi_generated_types.ml"]));
+
+ rule "generated ml"
+ ~dep:stubgen
+ ~prod:"ffi_generated.ml"
+ (fun _ _ ->
+ Cmd(S[P ("./" ^ stubgen); A"-ml"; Sh">"; A"ffi_generated.ml"]));
+
+ rule "generated-types c"
+ ~dep:stubgen_types
+ ~prod:"ffi_ml_types_stubgen.c"
+ (fun _ _ ->
+ Cmd (S [P ("./" ^ stubgen_types); Sh">"; A"ffi_ml_types_stubgen.c"]));
+
+ rule "generated-types exe"
+ ~dep:"ffi_ml_types_stubgen.c"
+ ~prod:stubgen_ml_types
+ (fun _ _ ->
+ let env = BaseEnvLight.load () in
+ let cc = BaseEnvLight.var_get "bytecomp_c_compiler" env in
+ let stdlib = BaseEnvLight.var_get "standard_library" env in
+ let ctypes = BaseEnvLight.var_get "pkg_ctypes_stubs" env in
+ Cmd (S [Sh cc; A"ffi_ml_types_stubgen.c";
+ A"-I"; P ctypes; A"-I"; P stdlib;A"-lkeystone";
+ A"-o"; A stubgen_ml_types])
+ );
+
+ rule "generated c"
+ ~dep:stubgen
+ ~prod:"ffi_generated_stubs.c"
+ (fun _ _ ->
+ Cmd(S[P ("./" ^ stubgen); A"-c"; Sh">"; A"ffi_generated_stubs.c"]));
+
+ flag ["c"; "compile"] & S[A"-I"; A"lib"; A"-package"; A"ctypes"; A"-package"; A"ctypes.stubs"]
+
+ | _ ->
+ ()
+
+let () = Ocamlbuild_plugin.dispatch (fun hook -> dispatch hook; dispatch_default hook)
diff --git a/bindings/ocaml/setup.ml b/bindings/ocaml/setup.ml
new file mode 100644
index 0000000000000000000000000000000000000000..aca3177483d63f02da20c6d65a279f66c5077dd2
--- /dev/null
+++ b/bindings/ocaml/setup.ml
@@ -0,0 +1,6940 @@
+(* setup.ml generated for the first time by OASIS v0.4.6 *)
+
+(* OASIS_START *)
+(* DO NOT EDIT (digest: e917c0324c290d1aa03c0a37379435b4) *)
+(*
+ Regenerated by OASIS v0.4.6
+ Visit http://oasis.forge.ocamlcore.org for more information and
+ documentation about functions used in this file.
+*)
+module OASISGettext = struct
+(* # 22 "src/oasis/OASISGettext.ml" *)
+
+
+ let ns_ str =
+ str
+
+
+ let s_ str =
+ str
+
+
+ let f_ (str: ('a, 'b, 'c, 'd) format4) =
+ str
+
+
+ let fn_ fmt1 fmt2 n =
+ if n = 1 then
+ fmt1^^""
+ else
+ fmt2^^""
+
+
+ let init =
+ []
+
+
+end
+
+module OASISContext = struct
+(* # 22 "src/oasis/OASISContext.ml" *)
+
+
+ open OASISGettext
+
+
+ type level =
+ [ `Debug
+ | `Info
+ | `Warning
+ | `Error]
+
+
+ type t =
+ {
+ (* TODO: replace this by a proplist. *)
+ quiet: bool;
+ info: bool;
+ debug: bool;
+ ignore_plugins: bool;
+ ignore_unknown_fields: bool;
+ printf: level -> string -> unit;
+ }
+
+
+ let printf lvl str =
+ let beg =
+ match lvl with
+ | `Error -> s_ "E: "
+ | `Warning -> s_ "W: "
+ | `Info -> s_ "I: "
+ | `Debug -> s_ "D: "
+ in
+ prerr_endline (beg^str)
+
+
+ let default =
+ ref
+ {
+ quiet = false;
+ info = false;
+ debug = false;
+ ignore_plugins = false;
+ ignore_unknown_fields = false;
+ printf = printf;
+ }
+
+
+ let quiet =
+ {!default with quiet = true}
+
+
+ let fspecs () =
+ (* TODO: don't act on default. *)
+ let ignore_plugins = ref false in
+ ["-quiet",
+ Arg.Unit (fun () -> default := {!default with quiet = true}),
+ s_ " Run quietly";
+
+ "-info",
+ Arg.Unit (fun () -> default := {!default with info = true}),
+ s_ " Display information message";
+
+
+ "-debug",
+ Arg.Unit (fun () -> default := {!default with debug = true}),
+ s_ " Output debug message";
+
+ "-ignore-plugins",
+ Arg.Set ignore_plugins,
+ s_ " Ignore plugin's field.";
+
+ "-C",
+ (* TODO: remove this chdir. *)
+ Arg.String (fun str -> Sys.chdir str),
+ s_ "dir Change directory before running."],
+ fun () -> {!default with ignore_plugins = !ignore_plugins}
+end
+
+module OASISString = struct
+(* # 22 "src/oasis/OASISString.ml" *)
+
+
+ (** Various string utilities.
+
+ Mostly inspired by extlib and batteries ExtString and BatString libraries.
+
+ @author Sylvain Le Gall
+ *)
+
+
+ let nsplitf str f =
+ if str = "" then
+ []
+ else
+ let buf = Buffer.create 13 in
+ let lst = ref [] in
+ let push () =
+ lst := Buffer.contents buf :: !lst;
+ Buffer.clear buf
+ in
+ let str_len = String.length str in
+ for i = 0 to str_len - 1 do
+ if f str.[i] then
+ push ()
+ else
+ Buffer.add_char buf str.[i]
+ done;
+ push ();
+ List.rev !lst
+
+
+ (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the
+ separator.
+ *)
+ let nsplit str c =
+ nsplitf str ((=) c)
+
+
+ let find ~what ?(offset=0) str =
+ let what_idx = ref 0 in
+ let str_idx = ref offset in
+ while !str_idx < String.length str &&
+ !what_idx < String.length what do
+ if str.[!str_idx] = what.[!what_idx] then
+ incr what_idx
+ else
+ what_idx := 0;
+ incr str_idx
+ done;
+ if !what_idx <> String.length what then
+ raise Not_found
+ else
+ !str_idx - !what_idx
+
+
+ let sub_start str len =
+ let str_len = String.length str in
+ if len >= str_len then
+ ""
+ else
+ String.sub str len (str_len - len)
+
+
+ let sub_end ?(offset=0) str len =
+ let str_len = String.length str in
+ if len >= str_len then
+ ""
+ else
+ String.sub str 0 (str_len - len)
+
+
+ let starts_with ~what ?(offset=0) str =
+ let what_idx = ref 0 in
+ let str_idx = ref offset in
+ let ok = ref true in
+ while !ok &&
+ !str_idx < String.length str &&
+ !what_idx < String.length what do
+ if str.[!str_idx] = what.[!what_idx] then
+ incr what_idx
+ else
+ ok := false;
+ incr str_idx
+ done;
+ if !what_idx = String.length what then
+ true
+ else
+ false
+
+
+ let strip_starts_with ~what str =
+ if starts_with ~what str then
+ sub_start str (String.length what)
+ else
+ raise Not_found
+
+
+ let ends_with ~what ?(offset=0) str =
+ let what_idx = ref ((String.length what) - 1) in
+ let str_idx = ref ((String.length str) - 1) in
+ let ok = ref true in
+ while !ok &&
+ offset <= !str_idx &&
+ 0 <= !what_idx do
+ if str.[!str_idx] = what.[!what_idx] then
+ decr what_idx
+ else
+ ok := false;
+ decr str_idx
+ done;
+ if !what_idx = -1 then
+ true
+ else
+ false
+
+
+ let strip_ends_with ~what str =
+ if ends_with ~what str then
+ sub_end str (String.length what)
+ else
+ raise Not_found
+
+
+ let replace_chars f s =
+ let buf = Buffer.create (String.length s) in
+ String.iter (fun c -> Buffer.add_char buf (f c)) s;
+ Buffer.contents buf
+
+ let lowercase_ascii =
+ replace_chars
+ (fun c ->
+ if (c >= 'A' && c <= 'Z') then
+ Char.chr (Char.code c + 32)
+ else
+ c)
+
+ let uncapitalize_ascii s =
+ if s <> "" then
+ (lowercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
+ else
+ s
+
+ let uppercase_ascii =
+ replace_chars
+ (fun c ->
+ if (c >= 'a' && c <= 'z') then
+ Char.chr (Char.code c - 32)
+ else
+ c)
+
+ let capitalize_ascii s =
+ if s <> "" then
+ (uppercase_ascii (String.sub s 0 1)) ^ (String.sub s 1 ((String.length s) - 1))
+ else
+ s
+
+end
+
+module OASISUtils = struct
+(* # 22 "src/oasis/OASISUtils.ml" *)
+
+
+ open OASISGettext
+
+
+ module MapExt =
+ struct
+ module type S =
+ sig
+ include Map.S
+ val add_list: 'a t -> (key * 'a) list -> 'a t
+ val of_list: (key * 'a) list -> 'a t
+ val to_list: 'a t -> (key * 'a) list
+ end
+
+ module Make (Ord: Map.OrderedType) =
+ struct
+ include Map.Make(Ord)
+
+ let rec add_list t =
+ function
+ | (k, v) :: tl -> add_list (add k v t) tl
+ | [] -> t
+
+ let of_list lst = add_list empty lst
+
+ let to_list t = fold (fun k v acc -> (k, v) :: acc) t []
+ end
+ end
+
+
+ module MapString = MapExt.Make(String)
+
+
+ module SetExt =
+ struct
+ module type S =
+ sig
+ include Set.S
+ val add_list: t -> elt list -> t
+ val of_list: elt list -> t
+ val to_list: t -> elt list
+ end
+
+ module Make (Ord: Set.OrderedType) =
+ struct
+ include Set.Make(Ord)
+
+ let rec add_list t =
+ function
+ | e :: tl -> add_list (add e t) tl
+ | [] -> t
+
+ let of_list lst = add_list empty lst
+
+ let to_list = elements
+ end
+ end
+
+
+ module SetString = SetExt.Make(String)
+
+
+ let compare_csl s1 s2 =
+ String.compare (OASISString.lowercase_ascii s1) (OASISString.lowercase_ascii s2)
+
+
+ module HashStringCsl =
+ Hashtbl.Make
+ (struct
+ type t = string
+ let equal s1 s2 = (compare_csl s1 s2) = 0
+ let hash s = Hashtbl.hash (OASISString.lowercase_ascii s)
+ end)
+
+ module SetStringCsl =
+ SetExt.Make
+ (struct
+ type t = string
+ let compare = compare_csl
+ end)
+
+
+ let varname_of_string ?(hyphen='_') s =
+ if String.length s = 0 then
+ begin
+ invalid_arg "varname_of_string"
+ end
+ else
+ begin
+ let buf =
+ OASISString.replace_chars
+ (fun c ->
+ if ('a' <= c && c <= 'z')
+ ||
+ ('A' <= c && c <= 'Z')
+ ||
+ ('0' <= c && c <= '9') then
+ c
+ else
+ hyphen)
+ s;
+ in
+ let buf =
+ (* Start with a _ if digit *)
+ if '0' <= s.[0] && s.[0] <= '9' then
+ "_"^buf
+ else
+ buf
+ in
+ OASISString.lowercase_ascii buf
+ end
+
+
+ let varname_concat ?(hyphen='_') p s =
+ let what = String.make 1 hyphen in
+ let p =
+ try
+ OASISString.strip_ends_with ~what p
+ with Not_found ->
+ p
+ in
+ let s =
+ try
+ OASISString.strip_starts_with ~what s
+ with Not_found ->
+ s
+ in
+ p^what^s
+
+
+ let is_varname str =
+ str = varname_of_string str
+
+
+ let failwithf fmt = Printf.ksprintf failwith fmt
+
+
+end
+
+module PropList = struct
+(* # 22 "src/oasis/PropList.ml" *)
+
+
+ open OASISGettext
+
+
+ type name = string
+
+
+ exception Not_set of name * string option
+ exception No_printer of name
+ exception Unknown_field of name * name
+
+
+ let () =
+ Printexc.register_printer
+ (function
+ | Not_set (nm, Some rsn) ->
+ Some
+ (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn)
+ | Not_set (nm, None) ->
+ Some
+ (Printf.sprintf (f_ "Field '%s' is not set") nm)
+ | No_printer nm ->
+ Some
+ (Printf.sprintf (f_ "No default printer for value %s") nm)
+ | Unknown_field (nm, schm) ->
+ Some
+ (Printf.sprintf
+ (f_ "Field %s is not defined in schema %s") nm schm)
+ | _ ->
+ None)
+
+
+ module Data =
+ struct
+ type t =
+ (name, unit -> unit) Hashtbl.t
+
+ let create () =
+ Hashtbl.create 13
+
+ let clear t =
+ Hashtbl.clear t
+
+
+(* # 78 "src/oasis/PropList.ml" *)
+ end
+
+
+ module Schema =
+ struct
+ type ('ctxt, 'extra) value =
+ {
+ get: Data.t -> string;
+ set: Data.t -> ?context:'ctxt -> string -> unit;
+ help: (unit -> string) option;
+ extra: 'extra;
+ }
+
+ type ('ctxt, 'extra) t =
+ {
+ name: name;
+ fields: (name, ('ctxt, 'extra) value) Hashtbl.t;
+ order: name Queue.t;
+ name_norm: string -> string;
+ }
+
+ let create ?(case_insensitive=false) nm =
+ {
+ name = nm;
+ fields = Hashtbl.create 13;
+ order = Queue.create ();
+ name_norm =
+ (if case_insensitive then
+ OASISString.lowercase_ascii
+ else
+ fun s -> s);
+ }
+
+ let add t nm set get extra help =
+ let key =
+ t.name_norm nm
+ in
+
+ if Hashtbl.mem t.fields key then
+ failwith
+ (Printf.sprintf
+ (f_ "Field '%s' is already defined in schema '%s'")
+ nm t.name);
+ Hashtbl.add
+ t.fields
+ key
+ {
+ set = set;
+ get = get;
+ help = help;
+ extra = extra;
+ };
+ Queue.add nm t.order
+
+ let mem t nm =
+ Hashtbl.mem t.fields nm
+
+ let find t nm =
+ try
+ Hashtbl.find t.fields (t.name_norm nm)
+ with Not_found ->
+ raise (Unknown_field (nm, t.name))
+
+ let get t data nm =
+ (find t nm).get data
+
+ let set t data nm ?context x =
+ (find t nm).set
+ data
+ ?context
+ x
+
+ let fold f acc t =
+ Queue.fold
+ (fun acc k ->
+ let v =
+ find t k
+ in
+ f acc k v.extra v.help)
+ acc
+ t.order
+
+ let iter f t =
+ fold
+ (fun () -> f)
+ ()
+ t
+
+ let name t =
+ t.name
+ end
+
+
+ module Field =
+ struct
+ type ('ctxt, 'value, 'extra) t =
+ {
+ set: Data.t -> ?context:'ctxt -> 'value -> unit;
+ get: Data.t -> 'value;
+ sets: Data.t -> ?context:'ctxt -> string -> unit;
+ gets: Data.t -> string;
+ help: (unit -> string) option;
+ extra: 'extra;
+ }
+
+ let new_id =
+ let last_id =
+ ref 0
+ in
+ fun () -> incr last_id; !last_id
+
+ let create ?schema ?name ?parse ?print ?default ?update ?help extra =
+ (* Default value container *)
+ let v =
+ ref None
+ in
+
+ (* If name is not given, create unique one *)
+ let nm =
+ match name with
+ | Some s -> s
+ | None -> Printf.sprintf "_anon_%d" (new_id ())
+ in
+
+ (* Last chance to get a value: the default *)
+ let default () =
+ match default with
+ | Some d -> d
+ | None -> raise (Not_set (nm, Some (s_ "no default value")))
+ in
+
+ (* Get data *)
+ let get data =
+ (* Get value *)
+ try
+ (Hashtbl.find data nm) ();
+ match !v with
+ | Some x -> x
+ | None -> default ()
+ with Not_found ->
+ default ()
+ in
+
+ (* Set data *)
+ let set data ?context x =
+ let x =
+ match update with
+ | Some f ->
+ begin
+ try
+ f ?context (get data) x
+ with Not_set _ ->
+ x
+ end
+ | None ->
+ x
+ in
+ Hashtbl.replace
+ data
+ nm
+ (fun () -> v := Some x)
+ in
+
+ (* Parse string value, if possible *)
+ let parse =
+ match parse with
+ | Some f ->
+ f
+ | None ->
+ fun ?context s ->
+ failwith
+ (Printf.sprintf
+ (f_ "Cannot parse field '%s' when setting value %S")
+ nm
+ s)
+ in
+
+ (* Set data, from string *)
+ let sets data ?context s =
+ set ?context data (parse ?context s)
+ in
+
+ (* Output value as string, if possible *)
+ let print =
+ match print with
+ | Some f ->
+ f
+ | None ->
+ fun _ -> raise (No_printer nm)
+ in
+
+ (* Get data, as a string *)
+ let gets data =
+ print (get data)
+ in
+
+ begin
+ match schema with
+ | Some t ->
+ Schema.add t nm sets gets extra help
+ | None ->
+ ()
+ end;
+
+ {
+ set = set;
+ get = get;
+ sets = sets;
+ gets = gets;
+ help = help;
+ extra = extra;
+ }
+
+ let fset data t ?context x =
+ t.set data ?context x
+
+ let fget data t =
+ t.get data
+
+ let fsets data t ?context s =
+ t.sets data ?context s
+
+ let fgets data t =
+ t.gets data
+ end
+
+
+ module FieldRO =
+ struct
+ let create ?schema ?name ?parse ?print ?default ?update ?help extra =
+ let fld =
+ Field.create ?schema ?name ?parse ?print ?default ?update ?help extra
+ in
+ fun data -> Field.fget data fld
+ end
+end
+
+module OASISMessage = struct
+(* # 22 "src/oasis/OASISMessage.ml" *)
+
+
+ open OASISGettext
+ open OASISContext
+
+
+ let generic_message ~ctxt lvl fmt =
+ let cond =
+ if ctxt.quiet then
+ false
+ else
+ match lvl with
+ | `Debug -> ctxt.debug
+ | `Info -> ctxt.info
+ | _ -> true
+ in
+ Printf.ksprintf
+ (fun str ->
+ if cond then
+ begin
+ ctxt.printf lvl str
+ end)
+ fmt
+
+
+ let debug ~ctxt fmt =
+ generic_message ~ctxt `Debug fmt
+
+
+ let info ~ctxt fmt =
+ generic_message ~ctxt `Info fmt
+
+
+ let warning ~ctxt fmt =
+ generic_message ~ctxt `Warning fmt
+
+
+ let error ~ctxt fmt =
+ generic_message ~ctxt `Error fmt
+
+end
+
+module OASISVersion = struct
+(* # 22 "src/oasis/OASISVersion.ml" *)
+
+
+ open OASISGettext
+
+
+
+
+
+ type s = string
+
+
+ type t = string
+
+
+ type comparator =
+ | VGreater of t
+ | VGreaterEqual of t
+ | VEqual of t
+ | VLesser of t
+ | VLesserEqual of t
+ | VOr of comparator * comparator
+ | VAnd of comparator * comparator
+
+
+
+ (* Range of allowed characters *)
+ let is_digit c =
+ '0' <= c && c <= '9'
+
+
+ let is_alpha c =
+ ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')
+
+
+ let is_special =
+ function
+ | '.' | '+' | '-' | '~' -> true
+ | _ -> false
+
+
+ let rec version_compare v1 v2 =
+ if v1 <> "" || v2 <> "" then
+ begin
+ (* Compare ascii string, using special meaning for version
+ * related char
+ *)
+ let val_ascii c =
+ if c = '~' then -1
+ else if is_digit c then 0
+ else if c = '\000' then 0
+ else if is_alpha c then Char.code c
+ else (Char.code c) + 256
+ in
+
+ let len1 = String.length v1 in
+ let len2 = String.length v2 in
+
+ let p = ref 0 in
+
+ (** Compare ascii part *)
+ let compare_vascii () =
+ let cmp = ref 0 in
+ while !cmp = 0 &&
+ !p < len1 && !p < len2 &&
+ not (is_digit v1.[!p] && is_digit v2.[!p]) do
+ cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]);
+ incr p
+ done;
+ if !cmp = 0 && !p < len1 && !p = len2 then
+ val_ascii v1.[!p]
+ else if !cmp = 0 && !p = len1 && !p < len2 then
+ - (val_ascii v2.[!p])
+ else
+ !cmp
+ in
+
+ (** Compare digit part *)
+ let compare_digit () =
+ let extract_int v p =
+ let start_p = !p in
+ while !p < String.length v && is_digit v.[!p] do
+ incr p
+ done;
+ let substr =
+ String.sub v !p ((String.length v) - !p)
+ in
+ let res =
+ match String.sub v start_p (!p - start_p) with
+ | "" -> 0
+ | s -> int_of_string s
+ in
+ res, substr
+ in
+ let i1, tl1 = extract_int v1 (ref !p) in
+ let i2, tl2 = extract_int v2 (ref !p) in
+ i1 - i2, tl1, tl2
+ in
+
+ match compare_vascii () with
+ | 0 ->
+ begin
+ match compare_digit () with
+ | 0, tl1, tl2 ->
+ if tl1 <> "" && is_digit tl1.[0] then
+ 1
+ else if tl2 <> "" && is_digit tl2.[0] then
+ -1
+ else
+ version_compare tl1 tl2
+ | n, _, _ ->
+ n
+ end
+ | n ->
+ n
+ end
+ else
+ begin
+ 0
+ end
+
+
+ let version_of_string str = str
+
+
+ let string_of_version t = t
+
+
+ let version_compare_string s1 s2 =
+ version_compare (version_of_string s1) (version_of_string s2)
+
+
+ let chop t =
+ try
+ let pos =
+ String.rindex t '.'
+ in
+ String.sub t 0 pos
+ with Not_found ->
+ t
+
+
+ let rec comparator_apply v op =
+ match op with
+ | VGreater cv ->
+ (version_compare v cv) > 0
+ | VGreaterEqual cv ->
+ (version_compare v cv) >= 0
+ | VLesser cv ->
+ (version_compare v cv) < 0
+ | VLesserEqual cv ->
+ (version_compare v cv) <= 0
+ | VEqual cv ->
+ (version_compare v cv) = 0
+ | VOr (op1, op2) ->
+ (comparator_apply v op1) || (comparator_apply v op2)
+ | VAnd (op1, op2) ->
+ (comparator_apply v op1) && (comparator_apply v op2)
+
+
+ let rec string_of_comparator =
+ function
+ | VGreater v -> "> "^(string_of_version v)
+ | VEqual v -> "= "^(string_of_version v)
+ | VLesser v -> "< "^(string_of_version v)
+ | VGreaterEqual v -> ">= "^(string_of_version v)
+ | VLesserEqual v -> "<= "^(string_of_version v)
+ | VOr (c1, c2) ->
+ (string_of_comparator c1)^" || "^(string_of_comparator c2)
+ | VAnd (c1, c2) ->
+ (string_of_comparator c1)^" && "^(string_of_comparator c2)
+
+
+ let rec varname_of_comparator =
+ let concat p v =
+ OASISUtils.varname_concat
+ p
+ (OASISUtils.varname_of_string
+ (string_of_version v))
+ in
+ function
+ | VGreater v -> concat "gt" v
+ | VLesser v -> concat "lt" v
+ | VEqual v -> concat "eq" v
+ | VGreaterEqual v -> concat "ge" v
+ | VLesserEqual v -> concat "le" v
+ | VOr (c1, c2) ->
+ (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2)
+ | VAnd (c1, c2) ->
+ (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2)
+
+
+ let rec comparator_ge v' =
+ let cmp v = version_compare v v' >= 0 in
+ function
+ | VEqual v
+ | VGreaterEqual v
+ | VGreater v -> cmp v
+ | VLesserEqual _
+ | VLesser _ -> false
+ | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2
+ | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2
+
+
+end
+
+module OASISLicense = struct
+(* # 22 "src/oasis/OASISLicense.ml" *)
+
+
+ (** License for _oasis fields
+ @author Sylvain Le Gall
+ *)
+
+
+
+
+
+ type license = string
+
+
+ type license_exception = string
+
+
+ type license_version =
+ | Version of OASISVersion.t
+ | VersionOrLater of OASISVersion.t
+ | NoVersion
+
+
+
+ type license_dep_5_unit =
+ {
+ license: license;
+ excption: license_exception option;
+ version: license_version;
+ }
+
+
+
+ type license_dep_5 =
+ | DEP5Unit of license_dep_5_unit
+ | DEP5Or of license_dep_5 list
+ | DEP5And of license_dep_5 list
+
+
+ type t =
+ | DEP5License of license_dep_5
+ | OtherLicense of string (* URL *)
+
+
+
+end
+
+module OASISExpr = struct
+(* # 22 "src/oasis/OASISExpr.ml" *)
+
+
+
+
+
+ open OASISGettext
+
+
+ type test = string
+
+
+ type flag = string
+
+
+ type t =
+ | EBool of bool
+ | ENot of t
+ | EAnd of t * t
+ | EOr of t * t
+ | EFlag of flag
+ | ETest of test * string
+
+
+
+ type 'a choices = (t * 'a) list
+
+
+ let eval var_get t =
+ let rec eval' =
+ function
+ | EBool b ->
+ b
+
+ | ENot e ->
+ not (eval' e)
+
+ | EAnd (e1, e2) ->
+ (eval' e1) && (eval' e2)
+
+ | EOr (e1, e2) ->
+ (eval' e1) || (eval' e2)
+
+ | EFlag nm ->
+ let v =
+ var_get nm
+ in
+ assert(v = "true" || v = "false");
+ (v = "true")
+
+ | ETest (nm, vl) ->
+ let v =
+ var_get nm
+ in
+ (v = vl)
+ in
+ eval' t
+
+
+ let choose ?printer ?name var_get lst =
+ let rec choose_aux =
+ function
+ | (cond, vl) :: tl ->
+ if eval var_get cond then
+ vl
+ else
+ choose_aux tl
+ | [] ->
+ let str_lst =
+ if lst = [] then
+ s_ "<empty>"
+ else
+ String.concat
+ (s_ ", ")
+ (List.map
+ (fun (cond, vl) ->
+ match printer with
+ | Some p -> p vl
+ | None -> s_ "<no printer>")
+ lst)
+ in
+ match name with
+ | Some nm ->
+ failwith
+ (Printf.sprintf
+ (f_ "No result for the choice list '%s': %s")
+ nm str_lst)
+ | None ->
+ failwith
+ (Printf.sprintf
+ (f_ "No result for a choice list: %s")
+ str_lst)
+ in
+ choose_aux (List.rev lst)
+
+
+end
+
+module OASISText = struct
+(* # 22 "src/oasis/OASISText.ml" *)
+
+
+
+ type elt =
+ | Para of string
+ | Verbatim of string
+ | BlankLine
+
+
+ type t = elt list
+
+end
+
+module OASISTypes = struct
+(* # 22 "src/oasis/OASISTypes.ml" *)
+
+
+
+
+
+ type name = string
+ type package_name = string
+ type url = string
+ type unix_dirname = string
+ type unix_filename = string
+ type host_dirname = string
+ type host_filename = string
+ type prog = string
+ type arg = string
+ type args = string list
+ type command_line = (prog * arg list)
+
+
+ type findlib_name = string
+ type findlib_full = string
+
+
+ type compiled_object =
+ | Byte
+ | Native
+ | Best
+
+
+
+ type dependency =
+ | FindlibPackage of findlib_full * OASISVersion.comparator option
+ | InternalLibrary of name
+
+
+
+ type tool =
+ | ExternalTool of name
+ | InternalExecutable of name
+
+
+
+ type vcs =
+ | Darcs
+ | Git
+ | Svn
+ | Cvs
+ | Hg
+ | Bzr
+ | Arch
+ | Monotone
+ | OtherVCS of url
+
+
+
+ type plugin_kind =
+ [ `Configure
+ | `Build
+ | `Doc
+ | `Test
+ | `Install
+ | `Extra
+ ]
+
+
+ type plugin_data_purpose =
+ [ `Configure
+ | `Build
+ | `Install
+ | `Clean
+ | `Distclean
+ | `Install
+ | `Uninstall
+ | `Test
+ | `Doc
+ | `Extra
+ | `Other of string
+ ]
+
+
+ type 'a plugin = 'a * name * OASISVersion.t option
+
+
+ type all_plugin = plugin_kind plugin
+
+
+ type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list
+
+
+(* # 115 "src/oasis/OASISTypes.ml" *)
+
+
+ type 'a conditional = 'a OASISExpr.choices
+
+
+ type custom =
+ {
+ pre_command: (command_line option) conditional;
+ post_command: (command_line option) conditional;
+ }
+
+
+
+ type common_section =
+ {
+ cs_name: name;
+ cs_data: PropList.Data.t;
+ cs_plugin_data: plugin_data;
+ }
+
+
+
+ type build_section =
+ {
+ bs_build: bool conditional;
+ bs_install: bool conditional;
+ bs_path: unix_dirname;
+ bs_compiled_object: compiled_object;
+ bs_build_depends: dependency list;
+ bs_build_tools: tool list;
+ bs_c_sources: unix_filename list;
+ bs_data_files: (unix_filename * unix_filename option) list;
+ bs_ccopt: args conditional;
+ bs_cclib: args conditional;
+ bs_dlllib: args conditional;
+ bs_dllpath: args conditional;
+ bs_byteopt: args conditional;
+ bs_nativeopt: args conditional;
+ }
+
+
+
+ type library =
+ {
+ lib_modules: string list;
+ lib_pack: bool;
+ lib_internal_modules: string list;
+ lib_findlib_parent: findlib_name option;
+ lib_findlib_name: findlib_name option;
+ lib_findlib_containers: findlib_name list;
+ }
+
+
+ type object_ =
+ {
+ obj_modules: string list;
+ obj_findlib_fullname: findlib_name list option;
+ }
+
+
+ type executable =
+ {
+ exec_custom: bool;
+ exec_main_is: unix_filename;
+ }
+
+
+ type flag =
+ {
+ flag_description: string option;
+ flag_default: bool conditional;
+ }
+
+
+ type source_repository =
+ {
+ src_repo_type: vcs;
+ src_repo_location: url;
+ src_repo_browser: url option;
+ src_repo_module: string option;
+ src_repo_branch: string option;
+ src_repo_tag: string option;
+ src_repo_subdir: unix_filename option;
+ }
+
+
+ type test =
+ {
+ test_type: [`Test] plugin;
+ test_command: command_line conditional;
+ test_custom: custom;
+ test_working_directory: unix_filename option;
+ test_run: bool conditional;
+ test_tools: tool list;
+ }
+
+
+ type doc_format =
+ | HTML of unix_filename
+ | DocText
+ | PDF
+ | PostScript
+ | Info of unix_filename
+ | DVI
+ | OtherDoc
+
+
+
+ type doc =
+ {
+ doc_type: [`Doc] plugin;
+ doc_custom: custom;
+ doc_build: bool conditional;
+ doc_install: bool conditional;
+ doc_install_dir: unix_filename;
+ doc_title: string;
+ doc_authors: string list;
+ doc_abstract: string option;
+ doc_format: doc_format;
+ doc_data_files: (unix_filename * unix_filename option) list;
+ doc_build_tools: tool list;
+ }
+
+
+ type section =
+ | Library of common_section * build_section * library
+ | Object of common_section * build_section * object_
+ | Executable of common_section * build_section * executable
+ | Flag of common_section * flag
+ | SrcRepo of common_section * source_repository
+ | Test of common_section * test
+ | Doc of common_section * doc
+
+
+
+ type section_kind =
+ [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
+
+
+ type package =
+ {
+ oasis_version: OASISVersion.t;
+ ocaml_version: OASISVersion.comparator option;
+ findlib_version: OASISVersion.comparator option;
+ alpha_features: string list;
+ beta_features: string list;
+ name: package_name;
+ version: OASISVersion.t;
+ license: OASISLicense.t;
+ license_file: unix_filename option;
+ copyrights: string list;
+ maintainers: string list;
+ authors: string list;
+ homepage: url option;
+ synopsis: string;
+ description: OASISText.t option;
+ categories: url list;
+
+ conf_type: [`Configure] plugin;
+ conf_custom: custom;
+
+ build_type: [`Build] plugin;
+ build_custom: custom;
+
+ install_type: [`Install] plugin;
+ install_custom: custom;
+ uninstall_custom: custom;
+
+ clean_custom: custom;
+ distclean_custom: custom;
+
+ files_ab: unix_filename list;
+ sections: section list;
+ plugins: [`Extra] plugin list;
+ disable_oasis_section: unix_filename list;
+ schema_data: PropList.Data.t;
+ plugin_data: plugin_data;
+ }
+
+
+end
+
+module OASISFeatures = struct
+(* # 22 "src/oasis/OASISFeatures.ml" *)
+
+ open OASISTypes
+ open OASISUtils
+ open OASISGettext
+ open OASISVersion
+
+ module MapPlugin =
+ Map.Make
+ (struct
+ type t = plugin_kind * name
+ let compare = Pervasives.compare
+ end)
+
+ module Data =
+ struct
+ type t =
+ {
+ oasis_version: OASISVersion.t;
+ plugin_versions: OASISVersion.t option MapPlugin.t;
+ alpha_features: string list;
+ beta_features: string list;
+ }
+
+ let create oasis_version alpha_features beta_features =
+ {
+ oasis_version = oasis_version;
+ plugin_versions = MapPlugin.empty;
+ alpha_features = alpha_features;
+ beta_features = beta_features
+ }
+
+ let of_package pkg =
+ create
+ pkg.OASISTypes.oasis_version
+ pkg.OASISTypes.alpha_features
+ pkg.OASISTypes.beta_features
+
+ let add_plugin (plugin_kind, plugin_name, plugin_version) t =
+ {t with
+ plugin_versions = MapPlugin.add
+ (plugin_kind, plugin_name)
+ plugin_version
+ t.plugin_versions}
+
+ let plugin_version plugin_kind plugin_name t =
+ MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions
+
+ let to_string t =
+ Printf.sprintf
+ "oasis_version: %s; alpha_features: %s; beta_features: %s; \
+ plugins_version: %s"
+ (OASISVersion.string_of_version t.oasis_version)
+ (String.concat ", " t.alpha_features)
+ (String.concat ", " t.beta_features)
+ (String.concat ", "
+ (MapPlugin.fold
+ (fun (_, plg) ver_opt acc ->
+ (plg^
+ (match ver_opt with
+ | Some v ->
+ " "^(OASISVersion.string_of_version v)
+ | None -> ""))
+ :: acc)
+ t.plugin_versions []))
+ end
+
+ type origin =
+ | Field of string * string
+ | Section of string
+ | NoOrigin
+
+ type stage = Alpha | Beta
+
+
+ let string_of_stage =
+ function
+ | Alpha -> "alpha"
+ | Beta -> "beta"
+
+
+ let field_of_stage =
+ function
+ | Alpha -> "AlphaFeatures"
+ | Beta -> "BetaFeatures"
+
+ type publication = InDev of stage | SinceVersion of OASISVersion.t
+
+ type t =
+ {
+ name: string;
+ plugin: all_plugin option;
+ publication: publication;
+ description: unit -> string;
+ }
+
+ (* TODO: mutex protect this. *)
+ let all_features = Hashtbl.create 13
+
+
+ let since_version ver_str = SinceVersion (version_of_string ver_str)
+ let alpha = InDev Alpha
+ let beta = InDev Beta
+
+
+ let to_string t =
+ Printf.sprintf
+ "feature: %s; plugin: %s; publication: %s"
+ t.name
+ (match t.plugin with
+ | None -> "<none>"
+ | Some (_, nm, _) -> nm)
+ (match t.publication with
+ | InDev stage -> string_of_stage stage
+ | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver))
+
+ let data_check t data origin =
+ let no_message = "no message" in
+
+ let check_feature features stage =
+ let has_feature = List.mem t.name features in
+ if not has_feature then
+ match origin with
+ | Field (fld, where) ->
+ Some
+ (Printf.sprintf
+ (f_ "Field %s in %s is only available when feature %s \
+ is in field %s.")
+ fld where t.name (field_of_stage stage))
+ | Section sct ->
+ Some
+ (Printf.sprintf
+ (f_ "Section %s is only available when features %s \
+ is in field %s.")
+ sct t.name (field_of_stage stage))
+ | NoOrigin ->
+ Some no_message
+ else
+ None
+ in
+
+ let version_is_good ~min_version version fmt =
+ let version_is_good =
+ OASISVersion.comparator_apply
+ version (OASISVersion.VGreaterEqual min_version)
+ in
+ Printf.ksprintf
+ (fun str ->
+ if version_is_good then
+ None
+ else
+ Some str)
+ fmt
+ in
+
+ match origin, t.plugin, t.publication with
+ | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha
+ | _, _, InDev Beta -> check_feature data.Data.beta_features Beta
+ | Field(fld, where), None, SinceVersion min_version ->
+ version_is_good ~min_version data.Data.oasis_version
+ (f_ "Field %s in %s is only valid since OASIS v%s, update \
+ OASISFormat field from '%s' to '%s' after checking \
+ OASIS changelog.")
+ fld where (string_of_version min_version)
+ (string_of_version data.Data.oasis_version)
+ (string_of_version min_version)
+
+ | Field(fld, where), Some(plugin_knd, plugin_name, _),
+ SinceVersion min_version ->
+ begin
+ try
+ let plugin_version_current =
+ try
+ match Data.plugin_version plugin_knd plugin_name data with
+ | Some ver -> ver
+ | None ->
+ failwithf
+ (f_ "Field %s in %s is only valid for the OASIS \
+ plugin %s since v%s, but no plugin version is \
+ defined in the _oasis file, change '%s' to \
+ '%s (%s)' in your _oasis file.")
+ fld where plugin_name (string_of_version min_version)
+ plugin_name
+ plugin_name (string_of_version min_version)
+ with Not_found ->
+ failwithf
+ (f_ "Field %s in %s is only valid when the OASIS plugin %s \
+ is defined.")
+ fld where plugin_name
+ in
+ version_is_good ~min_version plugin_version_current
+ (f_ "Field %s in %s is only valid for the OASIS plugin %s \
+ since v%s, update your plugin from '%s (%s)' to \
+ '%s (%s)' after checking the plugin's changelog.")
+ fld where plugin_name (string_of_version min_version)
+ plugin_name (string_of_version plugin_version_current)
+ plugin_name (string_of_version min_version)
+ with Failure msg ->
+ Some msg
+ end
+
+ | Section sct, None, SinceVersion min_version ->
+ version_is_good ~min_version data.Data.oasis_version
+ (f_ "Section %s is only valid for since OASIS v%s, update \
+ OASISFormat field from '%s' to '%s' after checking OASIS \
+ changelog.")
+ sct (string_of_version min_version)
+ (string_of_version data.Data.oasis_version)
+ (string_of_version min_version)
+
+ | Section sct, Some(plugin_knd, plugin_name, _),
+ SinceVersion min_version ->
+ begin
+ try
+ let plugin_version_current =
+ try
+ match Data.plugin_version plugin_knd plugin_name data with
+ | Some ver -> ver
+ | None ->
+ failwithf
+ (f_ "Section %s is only valid for the OASIS \
+ plugin %s since v%s, but no plugin version is \
+ defined in the _oasis file, change '%s' to \
+ '%s (%s)' in your _oasis file.")
+ sct plugin_name (string_of_version min_version)
+ plugin_name
+ plugin_name (string_of_version min_version)
+ with Not_found ->
+ failwithf
+ (f_ "Section %s is only valid when the OASIS plugin %s \
+ is defined.")
+ sct plugin_name
+ in
+ version_is_good ~min_version plugin_version_current
+ (f_ "Section %s is only valid for the OASIS plugin %s \
+ since v%s, update your plugin from '%s (%s)' to \
+ '%s (%s)' after checking the plugin's changelog.")
+ sct plugin_name (string_of_version min_version)
+ plugin_name (string_of_version plugin_version_current)
+ plugin_name (string_of_version min_version)
+ with Failure msg ->
+ Some msg
+ end
+
+ | NoOrigin, None, SinceVersion min_version ->
+ version_is_good ~min_version data.Data.oasis_version "%s" no_message
+
+ | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version ->
+ begin
+ try
+ let plugin_version_current =
+ match Data.plugin_version plugin_knd plugin_name data with
+ | Some ver -> ver
+ | None -> raise Not_found
+ in
+ version_is_good ~min_version plugin_version_current
+ "%s" no_message
+ with Not_found ->
+ Some no_message
+ end
+
+
+ let data_assert t data origin =
+ match data_check t data origin with
+ | None -> ()
+ | Some str -> failwith str
+
+
+ let data_test t data =
+ match data_check t data NoOrigin with
+ | None -> true
+ | Some str -> false
+
+
+ let package_test t pkg =
+ data_test t (Data.of_package pkg)
+
+
+ let create ?plugin name publication description =
+ let () =
+ if Hashtbl.mem all_features name then
+ failwithf "Feature '%s' is already declared." name
+ in
+ let t =
+ {
+ name = name;
+ plugin = plugin;
+ publication = publication;
+ description = description;
+ }
+ in
+ Hashtbl.add all_features name t;
+ t
+
+
+ let get_stage name =
+ try
+ (Hashtbl.find all_features name).publication
+ with Not_found ->
+ failwithf (f_ "Feature %s doesn't exist.") name
+
+
+ let list () =
+ Hashtbl.fold (fun _ v acc -> v :: acc) all_features []
+
+ (*
+ * Real flags.
+ *)
+
+
+ let features =
+ create "features_fields"
+ (since_version "0.4")
+ (fun () ->
+ s_ "Enable to experiment not yet official features.")
+
+
+ let flag_docs =
+ create "flag_docs"
+ (since_version "0.3")
+ (fun () ->
+ s_ "Building docs require '-docs' flag at configure.")
+
+
+ let flag_tests =
+ create "flag_tests"
+ (since_version "0.3")
+ (fun () ->
+ s_ "Running tests require '-tests' flag at configure.")
+
+
+ let pack =
+ create "pack"
+ (since_version "0.3")
+ (fun () ->
+ s_ "Allow to create packed library.")
+
+
+ let section_object =
+ create "section_object" beta
+ (fun () ->
+ s_ "Implement an object section.")
+
+
+ let dynrun_for_release =
+ create "dynrun_for_release" alpha
+ (fun () ->
+ s_ "Make '-setup-update dynamic' suitable for releasing project.")
+
+
+ let compiled_setup_ml =
+ create "compiled_setup_ml" alpha
+ (fun () ->
+ s_ "It compiles the setup.ml and speed-up actions done with it.")
+
+ let disable_oasis_section =
+ create "disable_oasis_section" alpha
+ (fun () ->
+ s_ "Allows the OASIS section comments and digest to be omitted in \
+ generated files.")
+
+ let no_automatic_syntax =
+ create "no_automatic_syntax" alpha
+ (fun () ->
+ s_ "Disable the automatic inclusion of -syntax camlp4o for packages \
+ that matches the internal heuristic (if a dependency ends with \
+ a .syntax or is a well known syntax).")
+end
+
+module OASISUnixPath = struct
+(* # 22 "src/oasis/OASISUnixPath.ml" *)
+
+
+ type unix_filename = string
+ type unix_dirname = string
+
+
+ type host_filename = string
+ type host_dirname = string
+
+
+ let current_dir_name = "."
+
+
+ let parent_dir_name = ".."
+
+
+ let is_current_dir fn =
+ fn = current_dir_name || fn = ""
+
+
+ let concat f1 f2 =
+ if is_current_dir f1 then
+ f2
+ else
+ let f1' =
+ try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1
+ in
+ f1'^"/"^f2
+
+
+ let make =
+ function
+ | hd :: tl ->
+ List.fold_left
+ (fun f p -> concat f p)
+ hd
+ tl
+ | [] ->
+ invalid_arg "OASISUnixPath.make"
+
+
+ let dirname f =
+ try
+ String.sub f 0 (String.rindex f '/')
+ with Not_found ->
+ current_dir_name
+
+
+ let basename f =
+ try
+ let pos_start =
+ (String.rindex f '/') + 1
+ in
+ String.sub f pos_start ((String.length f) - pos_start)
+ with Not_found ->
+ f
+
+
+ let chop_extension f =
+ try
+ let last_dot =
+ String.rindex f '.'
+ in
+ let sub =
+ String.sub f 0 last_dot
+ in
+ try
+ let last_slash =
+ String.rindex f '/'
+ in
+ if last_slash < last_dot then
+ sub
+ else
+ f
+ with Not_found ->
+ sub
+
+ with Not_found ->
+ f
+
+
+ let capitalize_file f =
+ let dir = dirname f in
+ let base = basename f in
+ concat dir (OASISString.capitalize_ascii base)
+
+
+ let uncapitalize_file f =
+ let dir = dirname f in
+ let base = basename f in
+ concat dir (OASISString.uncapitalize_ascii base)
+
+
+end
+
+module OASISHostPath = struct
+(* # 22 "src/oasis/OASISHostPath.ml" *)
+
+
+ open Filename
+
+
+ module Unix = OASISUnixPath
+
+
+ let make =
+ function
+ | [] ->
+ invalid_arg "OASISHostPath.make"
+ | hd :: tl ->
+ List.fold_left Filename.concat hd tl
+
+
+ let of_unix ufn =
+ if Sys.os_type = "Unix" then
+ ufn
+ else
+ make
+ (List.map
+ (fun p ->
+ if p = Unix.current_dir_name then
+ current_dir_name
+ else if p = Unix.parent_dir_name then
+ parent_dir_name
+ else
+ p)
+ (OASISString.nsplit ufn '/'))
+
+
+end
+
+module OASISSection = struct
+(* # 22 "src/oasis/OASISSection.ml" *)
+
+
+ open OASISTypes
+
+
+ let section_kind_common =
+ function
+ | Library (cs, _, _) ->
+ `Library, cs
+ | Object (cs, _, _) ->
+ `Object, cs
+ | Executable (cs, _, _) ->
+ `Executable, cs
+ | Flag (cs, _) ->
+ `Flag, cs
+ | SrcRepo (cs, _) ->
+ `SrcRepo, cs
+ | Test (cs, _) ->
+ `Test, cs
+ | Doc (cs, _) ->
+ `Doc, cs
+
+
+ let section_common sct =
+ snd (section_kind_common sct)
+
+
+ let section_common_set cs =
+ function
+ | Library (_, bs, lib) -> Library (cs, bs, lib)
+ | Object (_, bs, obj) -> Object (cs, bs, obj)
+ | Executable (_, bs, exec) -> Executable (cs, bs, exec)
+ | Flag (_, flg) -> Flag (cs, flg)
+ | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo)
+ | Test (_, tst) -> Test (cs, tst)
+ | Doc (_, doc) -> Doc (cs, doc)
+
+
+ (** Key used to identify section
+ *)
+ let section_id sct =
+ let k, cs =
+ section_kind_common sct
+ in
+ k, cs.cs_name
+
+
+ let string_of_section sct =
+ let k, nm =
+ section_id sct
+ in
+ (match k with
+ | `Library -> "library"
+ | `Object -> "object"
+ | `Executable -> "executable"
+ | `Flag -> "flag"
+ | `SrcRepo -> "src repository"
+ | `Test -> "test"
+ | `Doc -> "doc")
+ ^" "^nm
+
+
+ let section_find id scts =
+ List.find
+ (fun sct -> id = section_id sct)
+ scts
+
+
+ module CSection =
+ struct
+ type t = section
+
+ let id = section_id
+
+ let compare t1 t2 =
+ compare (id t1) (id t2)
+
+ let equal t1 t2 =
+ (id t1) = (id t2)
+
+ let hash t =
+ Hashtbl.hash (id t)
+ end
+
+
+ module MapSection = Map.Make(CSection)
+ module SetSection = Set.Make(CSection)
+
+
+end
+
+module OASISBuildSection = struct
+(* # 22 "src/oasis/OASISBuildSection.ml" *)
+
+
+end
+
+module OASISExecutable = struct
+(* # 22 "src/oasis/OASISExecutable.ml" *)
+
+
+ open OASISTypes
+
+
+ let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program =
+ let dir =
+ OASISUnixPath.concat
+ bs.bs_path
+ (OASISUnixPath.dirname exec.exec_main_is)
+ in
+ let is_native_exec =
+ match bs.bs_compiled_object with
+ | Native -> true
+ | Best -> is_native ()
+ | Byte -> false
+ in
+
+ OASISUnixPath.concat
+ dir
+ (cs.cs_name^(suffix_program ())),
+
+ if not is_native_exec &&
+ not exec.exec_custom &&
+ bs.bs_c_sources <> [] then
+ Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ()))
+ else
+ None
+
+
+end
+
+module OASISLibrary = struct
+(* # 22 "src/oasis/OASISLibrary.ml" *)
+
+
+ open OASISTypes
+ open OASISUtils
+ open OASISGettext
+ open OASISSection
+
+
+ (* Look for a module file, considering capitalization or not. *)
+ let find_module source_file_exists bs modul =
+ let possible_base_fn =
+ List.map
+ (OASISUnixPath.concat bs.bs_path)
+ [modul;
+ OASISUnixPath.uncapitalize_file modul;
+ OASISUnixPath.capitalize_file modul]
+ in
+ (* TODO: we should be able to be able to determine the source for every
+ * files. Hence we should introduce a Module(source: fn) for the fields
+ * Modules and InternalModules
+ *)
+ List.fold_left
+ (fun acc base_fn ->
+ match acc with
+ | `No_sources _ ->
+ begin
+ let file_found =
+ List.fold_left
+ (fun acc ext ->
+ if source_file_exists (base_fn^ext) then
+ (base_fn^ext) :: acc
+ else
+ acc)
+ []
+ [".ml"; ".mli"; ".mll"; ".mly"]
+ in
+ match file_found with
+ | [] ->
+ acc
+ | lst ->
+ `Sources (base_fn, lst)
+ end
+ | `Sources _ ->
+ acc)
+ (`No_sources possible_base_fn)
+ possible_base_fn
+
+
+ let source_unix_files ~ctxt (cs, bs, lib) source_file_exists =
+ List.fold_left
+ (fun acc modul ->
+ match find_module source_file_exists bs modul with
+ | `Sources (base_fn, lst) ->
+ (base_fn, lst) :: acc
+ | `No_sources _ ->
+ OASISMessage.warning
+ ~ctxt
+ (f_ "Cannot find source file matching \
+ module '%s' in library %s")
+ modul cs.cs_name;
+ acc)
+ []
+ (lib.lib_modules @ lib.lib_internal_modules)
+
+
+ let generated_unix_files
+ ~ctxt
+ ~is_native
+ ~has_native_dynlink
+ ~ext_lib
+ ~ext_dll
+ ~source_file_exists
+ (cs, bs, lib) =
+
+ let find_modules lst ext =
+ let find_module modul =
+ match find_module source_file_exists bs modul with
+ | `Sources (base_fn, [fn]) when ext <> "cmi"
+ && Filename.check_suffix fn ".mli" ->
+ None (* No implementation files for pure interface. *)
+ | `Sources (base_fn, _) ->
+ Some [base_fn]
+ | `No_sources lst ->
+ OASISMessage.warning
+ ~ctxt
+ (f_ "Cannot find source file matching \
+ module '%s' in library %s")
+ modul cs.cs_name;
+ Some lst
+ in
+ List.fold_left
+ (fun acc nm ->
+ match find_module nm with
+ | None -> acc
+ | Some base_fns ->
+ List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc)
+ []
+ lst
+ in
+
+ (* The .cmx that be compiled along *)
+ let cmxs =
+ let should_be_built =
+ match bs.bs_compiled_object with
+ | Native -> true
+ | Best -> is_native
+ | Byte -> false
+ in
+ if should_be_built then
+ if lib.lib_pack then
+ find_modules
+ [cs.cs_name]
+ "cmx"
+ else
+ find_modules
+ (lib.lib_modules @ lib.lib_internal_modules)
+ "cmx"
+ else
+ []
+ in
+
+ let acc_nopath =
+ []
+ in
+
+ (* The headers and annot/cmt files that should be compiled along *)
+ let headers =
+ let sufx =
+ if lib.lib_pack
+ then [".cmti"; ".cmt"; ".annot"]
+ else [".cmi"; ".cmti"; ".cmt"; ".annot"]
+ in
+ List.map
+ begin
+ List.fold_left
+ begin fun accu s ->
+ let dot = String.rindex s '.' in
+ let base = String.sub s 0 dot in
+ List.map ((^) base) sufx @ accu
+ end
+ []
+ end
+ (find_modules lib.lib_modules "cmi")
+ in
+
+ (* Compute what libraries should be built *)
+ let acc_nopath =
+ (* Add the packed header file if required *)
+ let add_pack_header acc =
+ if lib.lib_pack then
+ [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc
+ else
+ acc
+ in
+ let byte acc =
+ add_pack_header ([cs.cs_name^".cma"] :: acc)
+ in
+ let native acc =
+ let acc =
+ add_pack_header
+ (if has_native_dynlink then
+ [cs.cs_name^".cmxs"] :: acc
+ else acc)
+ in
+ [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc
+ in
+ match bs.bs_compiled_object with
+ | Native ->
+ byte (native acc_nopath)
+ | Best when is_native ->
+ byte (native acc_nopath)
+ | Byte | Best ->
+ byte acc_nopath
+ in
+
+ (* Add C library to be built *)
+ let acc_nopath =
+ if bs.bs_c_sources <> [] then
+ begin
+ ["lib"^cs.cs_name^"_stubs"^ext_lib]
+ ::
+ ["dll"^cs.cs_name^"_stubs"^ext_dll]
+ ::
+ acc_nopath
+ end
+ else
+ acc_nopath
+ in
+
+ (* All the files generated *)
+ List.rev_append
+ (List.rev_map
+ (List.rev_map
+ (OASISUnixPath.concat bs.bs_path))
+ acc_nopath)
+ (headers @ cmxs)
+
+
+end
+
+module OASISObject = struct
+(* # 22 "src/oasis/OASISObject.ml" *)
+
+
+ open OASISTypes
+ open OASISGettext
+
+
+ let source_unix_files ~ctxt (cs, bs, obj) source_file_exists =
+ List.fold_left
+ (fun acc modul ->
+ match OASISLibrary.find_module source_file_exists bs modul with
+ | `Sources (base_fn, lst) ->
+ (base_fn, lst) :: acc
+ | `No_sources _ ->
+ OASISMessage.warning
+ ~ctxt
+ (f_ "Cannot find source file matching \
+ module '%s' in object %s")
+ modul cs.cs_name;
+ acc)
+ []
+ obj.obj_modules
+
+
+ let generated_unix_files
+ ~ctxt
+ ~is_native
+ ~source_file_exists
+ (cs, bs, obj) =
+
+ let find_module ext modul =
+ match OASISLibrary.find_module source_file_exists bs modul with
+ | `Sources (base_fn, _) -> [base_fn ^ ext]
+ | `No_sources lst ->
+ OASISMessage.warning
+ ~ctxt
+ (f_ "Cannot find source file matching \
+ module '%s' in object %s")
+ modul cs.cs_name ;
+ lst
+ in
+
+ let header, byte, native, c_object, f =
+ match obj.obj_modules with
+ | [ m ] -> (find_module ".cmi" m,
+ find_module ".cmo" m,
+ find_module ".cmx" m,
+ find_module ".o" m,
+ fun x -> x)
+ | _ -> ([cs.cs_name ^ ".cmi"],
+ [cs.cs_name ^ ".cmo"],
+ [cs.cs_name ^ ".cmx"],
+ [cs.cs_name ^ ".o"],
+ OASISUnixPath.concat bs.bs_path)
+ in
+ List.map (List.map f) (
+ match bs.bs_compiled_object with
+ | Native ->
+ native :: c_object :: byte :: header :: []
+ | Best when is_native ->
+ native :: c_object :: byte :: header :: []
+ | Byte | Best ->
+ byte :: header :: [])
+
+
+end
+
+module OASISFindlib = struct
+(* # 22 "src/oasis/OASISFindlib.ml" *)
+
+
+ open OASISTypes
+ open OASISUtils
+ open OASISGettext
+ open OASISSection
+
+
+ type library_name = name
+ type findlib_part_name = name
+ type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t
+
+
+ exception InternalLibraryNotFound of library_name
+ exception FindlibPackageNotFound of findlib_name
+
+
+ type group_t =
+ | Container of findlib_name * group_t list
+ | Package of (findlib_name *
+ common_section *
+ build_section *
+ [`Library of library | `Object of object_] *
+ group_t list)
+
+
+ type data = common_section *
+ build_section *
+ [`Library of library | `Object of object_]
+ type tree =
+ | Node of (data option) * (tree MapString.t)
+ | Leaf of data
+
+
+ let findlib_mapping pkg =
+ (* Map from library name to either full findlib name or parts + parent. *)
+ let fndlb_parts_of_lib_name =
+ let fndlb_parts cs lib =
+ let name =
+ match lib.lib_findlib_name with
+ | Some nm -> nm
+ | None -> cs.cs_name
+ in
+ let name =
+ String.concat "." (lib.lib_findlib_containers @ [name])
+ in
+ name
+ in
+ List.fold_left
+ (fun mp ->
+ function
+ | Library (cs, _, lib) ->
+ begin
+ let lib_name = cs.cs_name in
+ let fndlb_parts = fndlb_parts cs lib in
+ if MapString.mem lib_name mp then
+ failwithf
+ (f_ "The library name '%s' is used more than once.")
+ lib_name;
+ match lib.lib_findlib_parent with
+ | Some lib_name_parent ->
+ MapString.add
+ lib_name
+ (`Unsolved (lib_name_parent, fndlb_parts))
+ mp
+ | None ->
+ MapString.add
+ lib_name
+ (`Solved fndlb_parts)
+ mp
+ end
+
+ | Object (cs, _, obj) ->
+ begin
+ let obj_name = cs.cs_name in
+ if MapString.mem obj_name mp then
+ failwithf
+ (f_ "The object name '%s' is used more than once.")
+ obj_name;
+ let findlib_full_name = match obj.obj_findlib_fullname with
+ | Some ns -> String.concat "." ns
+ | None -> obj_name
+ in
+ MapString.add
+ obj_name
+ (`Solved findlib_full_name)
+ mp
+ end
+
+ | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ ->
+ mp)
+ MapString.empty
+ pkg.sections
+ in
+
+ (* Solve the above graph to be only library name to full findlib name. *)
+ let fndlb_name_of_lib_name =
+ let rec solve visited mp lib_name lib_name_child =
+ if SetString.mem lib_name visited then
+ failwithf
+ (f_ "Library '%s' is involved in a cycle \
+ with regard to findlib naming.")
+ lib_name;
+ let visited = SetString.add lib_name visited in
+ try
+ match MapString.find lib_name mp with
+ | `Solved fndlb_nm ->
+ fndlb_nm, mp
+ | `Unsolved (lib_nm_parent, post_fndlb_nm) ->
+ let pre_fndlb_nm, mp =
+ solve visited mp lib_nm_parent lib_name
+ in
+ let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in
+ fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp
+ with Not_found ->
+ failwithf
+ (f_ "Library '%s', which is defined as the findlib parent of \
+ library '%s', doesn't exist.")
+ lib_name lib_name_child
+ in
+ let mp =
+ MapString.fold
+ (fun lib_name status mp ->
+ match status with
+ | `Solved _ ->
+ (* Solved initialy, no need to go further *)
+ mp
+ | `Unsolved _ ->
+ let _, mp = solve SetString.empty mp lib_name "<none>" in
+ mp)
+ fndlb_parts_of_lib_name
+ fndlb_parts_of_lib_name
+ in
+ MapString.map
+ (function
+ | `Solved fndlb_nm -> fndlb_nm
+ | `Unsolved _ -> assert false)
+ mp
+ in
+
+ (* Convert an internal library name to a findlib name. *)
+ let findlib_name_of_library_name lib_nm =
+ try
+ MapString.find lib_nm fndlb_name_of_lib_name
+ with Not_found ->
+ raise (InternalLibraryNotFound lib_nm)
+ in
+
+ (* Add a library to the tree.
+ *)
+ let add sct mp =
+ let fndlb_fullname =
+ let cs, _, _ = sct in
+ let lib_name = cs.cs_name in
+ findlib_name_of_library_name lib_name
+ in
+ let rec add_children nm_lst (children: tree MapString.t) =
+ match nm_lst with
+ | (hd :: tl) ->
+ begin
+ let node =
+ try
+ add_node tl (MapString.find hd children)
+ with Not_found ->
+ (* New node *)
+ new_node tl
+ in
+ MapString.add hd node children
+ end
+ | [] ->
+ (* Should not have a nameless library. *)
+ assert false
+ and add_node tl node =
+ if tl = [] then
+ begin
+ match node with
+ | Node (None, children) ->
+ Node (Some sct, children)
+ | Leaf (cs', _, _) | Node (Some (cs', _, _), _) ->
+ (* TODO: allow to merge Package, i.e.
+ * archive(byte) = "foo.cma foo_init.cmo"
+ *)
+ let cs, _, _ = sct in
+ failwithf
+ (f_ "Library '%s' and '%s' have the same findlib name '%s'")
+ cs.cs_name cs'.cs_name fndlb_fullname
+ end
+ else
+ begin
+ match node with
+ | Leaf data ->
+ Node (Some data, add_children tl MapString.empty)
+ | Node (data_opt, children) ->
+ Node (data_opt, add_children tl children)
+ end
+ and new_node =
+ function
+ | [] ->
+ Leaf sct
+ | hd :: tl ->
+ Node (None, MapString.add hd (new_node tl) MapString.empty)
+ in
+ add_children (OASISString.nsplit fndlb_fullname '.') mp
+ in
+
+ let rec group_of_tree mp =
+ MapString.fold
+ (fun nm node acc ->
+ let cur =
+ match node with
+ | Node (Some (cs, bs, lib), children) ->
+ Package (nm, cs, bs, lib, group_of_tree children)
+ | Node (None, children) ->
+ Container (nm, group_of_tree children)
+ | Leaf (cs, bs, lib) ->
+ Package (nm, cs, bs, lib, [])
+ in
+ cur :: acc)
+ mp []
+ in
+
+ let group_mp =
+ List.fold_left
+ (fun mp ->
+ function
+ | Library (cs, bs, lib) ->
+ add (cs, bs, `Library lib) mp
+ | Object (cs, bs, obj) ->
+ add (cs, bs, `Object obj) mp
+ | _ ->
+ mp)
+ MapString.empty
+ pkg.sections
+ in
+
+ let groups =
+ group_of_tree group_mp
+ in
+
+ let library_name_of_findlib_name =
+ lazy begin
+ (* Revert findlib_name_of_library_name. *)
+ MapString.fold
+ (fun k v mp -> MapString.add v k mp)
+ fndlb_name_of_lib_name
+ MapString.empty
+ end
+ in
+ let library_name_of_findlib_name fndlb_nm =
+ try
+ MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name)
+ with Not_found ->
+ raise (FindlibPackageNotFound fndlb_nm)
+ in
+
+ groups,
+ findlib_name_of_library_name,
+ library_name_of_findlib_name
+
+
+ let findlib_of_group =
+ function
+ | Container (fndlb_nm, _)
+ | Package (fndlb_nm, _, _, _, _) -> fndlb_nm
+
+
+ let root_of_group grp =
+ let rec root_lib_aux =
+ (* We do a DFS in the group. *)
+ function
+ | Container (_, children) ->
+ List.fold_left
+ (fun res grp ->
+ if res = None then
+ root_lib_aux grp
+ else
+ res)
+ None
+ children
+ | Package (_, cs, bs, lib, _) ->
+ Some (cs, bs, lib)
+ in
+ match root_lib_aux grp with
+ | Some res ->
+ res
+ | None ->
+ failwithf
+ (f_ "Unable to determine root library of findlib library '%s'")
+ (findlib_of_group grp)
+
+
+end
+
+module OASISFlag = struct
+(* # 22 "src/oasis/OASISFlag.ml" *)
+
+
+end
+
+module OASISPackage = struct
+(* # 22 "src/oasis/OASISPackage.ml" *)
+
+
+end
+
+module OASISSourceRepository = struct
+(* # 22 "src/oasis/OASISSourceRepository.ml" *)
+
+
+end
+
+module OASISTest = struct
+(* # 22 "src/oasis/OASISTest.ml" *)
+
+
+end
+
+module OASISDocument = struct
+(* # 22 "src/oasis/OASISDocument.ml" *)
+
+
+end
+
+module OASISExec = struct
+(* # 22 "src/oasis/OASISExec.ml" *)
+
+
+ open OASISGettext
+ open OASISUtils
+ open OASISMessage
+
+
+ (* TODO: I don't like this quote, it is there because $(rm) foo expands to
+ * 'rm -f' foo...
+ *)
+ let run ~ctxt ?f_exit_code ?(quote=true) cmd args =
+ let cmd =
+ if quote then
+ if Sys.os_type = "Win32" then
+ if String.contains cmd ' ' then
+ (* Double the 1st double quote... win32... sigh *)
+ "\""^(Filename.quote cmd)
+ else
+ cmd
+ else
+ Filename.quote cmd
+ else
+ cmd
+ in
+ let cmdline =
+ String.concat " " (cmd :: args)
+ in
+ info ~ctxt (f_ "Running command '%s'") cmdline;
+ match f_exit_code, Sys.command cmdline with
+ | None, 0 -> ()
+ | None, i ->
+ failwithf
+ (f_ "Command '%s' terminated with error code %d")
+ cmdline i
+ | Some f, i ->
+ f i
+
+
+ let run_read_output ~ctxt ?f_exit_code cmd args =
+ let fn =
+ Filename.temp_file "oasis-" ".txt"
+ in
+ try
+ begin
+ let () =
+ run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn])
+ in
+ let chn =
+ open_in fn
+ in
+ let routput =
+ ref []
+ in
+ begin
+ try
+ while true do
+ routput := (input_line chn) :: !routput
+ done
+ with End_of_file ->
+ ()
+ end;
+ close_in chn;
+ Sys.remove fn;
+ List.rev !routput
+ end
+ with e ->
+ (try Sys.remove fn with _ -> ());
+ raise e
+
+
+ let run_read_one_line ~ctxt ?f_exit_code cmd args =
+ match run_read_output ~ctxt ?f_exit_code cmd args with
+ | [fst] ->
+ fst
+ | lst ->
+ failwithf
+ (f_ "Command return unexpected output %S")
+ (String.concat "\n" lst)
+end
+
+module OASISFileUtil = struct
+(* # 22 "src/oasis/OASISFileUtil.ml" *)
+
+
+ open OASISGettext
+
+
+ let file_exists_case fn =
+ let dirname = Filename.dirname fn in
+ let basename = Filename.basename fn in
+ if Sys.file_exists dirname then
+ if basename = Filename.current_dir_name then
+ true
+ else
+ List.mem
+ basename
+ (Array.to_list (Sys.readdir dirname))
+ else
+ false
+
+
+ let find_file ?(case_sensitive=true) paths exts =
+
+ (* Cardinal product of two list *)
+ let ( * ) lst1 lst2 =
+ List.flatten
+ (List.map
+ (fun a ->
+ List.map
+ (fun b -> a, b)
+ lst2)
+ lst1)
+ in
+
+ let rec combined_paths lst =
+ match lst with
+ | p1 :: p2 :: tl ->
+ let acc =
+ (List.map
+ (fun (a, b) -> Filename.concat a b)
+ (p1 * p2))
+ in
+ combined_paths (acc :: tl)
+ | [e] ->
+ e
+ | [] ->
+ []
+ in
+
+ let alternatives =
+ List.map
+ (fun (p, e) ->
+ if String.length e > 0 && e.[0] <> '.' then
+ p ^ "." ^ e
+ else
+ p ^ e)
+ ((combined_paths paths) * exts)
+ in
+ List.find (fun file ->
+ (if case_sensitive then
+ file_exists_case file
+ else
+ Sys.file_exists file)
+ && not (Sys.is_directory file)
+ ) alternatives
+
+
+ let which ~ctxt prg =
+ let path_sep =
+ match Sys.os_type with
+ | "Win32" ->
+ ';'
+ | _ ->
+ ':'
+ in
+ let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in
+ let exec_ext =
+ match Sys.os_type with
+ | "Win32" ->
+ "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep)
+ | _ ->
+ [""]
+ in
+ find_file ~case_sensitive:false [path_lst; [prg]] exec_ext
+
+
+ (**/**)
+ let rec fix_dir dn =
+ (* Windows hack because Sys.file_exists "src\\" = false when
+ * Sys.file_exists "src" = true
+ *)
+ let ln =
+ String.length dn
+ in
+ if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then
+ fix_dir (String.sub dn 0 (ln - 1))
+ else
+ dn
+
+
+ let q = Filename.quote
+ (**/**)
+
+
+ let cp ~ctxt ?(recurse=false) src tgt =
+ if recurse then
+ match Sys.os_type with
+ | "Win32" ->
+ OASISExec.run ~ctxt
+ "xcopy" [q src; q tgt; "/E"]
+ | _ ->
+ OASISExec.run ~ctxt
+ "cp" ["-r"; q src; q tgt]
+ else
+ OASISExec.run ~ctxt
+ (match Sys.os_type with
+ | "Win32" -> "copy"
+ | _ -> "cp")
+ [q src; q tgt]
+
+
+ let mkdir ~ctxt tgt =
+ OASISExec.run ~ctxt
+ (match Sys.os_type with
+ | "Win32" -> "md"
+ | _ -> "mkdir")
+ [q tgt]
+
+
+ let rec mkdir_parent ~ctxt f tgt =
+ let tgt =
+ fix_dir tgt
+ in
+ if Sys.file_exists tgt then
+ begin
+ if not (Sys.is_directory tgt) then
+ OASISUtils.failwithf
+ (f_ "Cannot create directory '%s', a file of the same name already \
+ exists")
+ tgt
+ end
+ else
+ begin
+ mkdir_parent ~ctxt f (Filename.dirname tgt);
+ if not (Sys.file_exists tgt) then
+ begin
+ f tgt;
+ mkdir ~ctxt tgt
+ end
+ end
+
+
+ let rmdir ~ctxt tgt =
+ if Sys.readdir tgt = [||] then begin
+ match Sys.os_type with
+ | "Win32" ->
+ OASISExec.run ~ctxt "rd" [q tgt]
+ | _ ->
+ OASISExec.run ~ctxt "rm" ["-r"; q tgt]
+ end else begin
+ OASISMessage.error ~ctxt
+ (f_ "Cannot remove directory '%s': not empty.")
+ tgt
+ end
+
+
+ let glob ~ctxt fn =
+ let basename =
+ Filename.basename fn
+ in
+ if String.length basename >= 2 &&
+ basename.[0] = '*' &&
+ basename.[1] = '.' then
+ begin
+ let ext_len =
+ (String.length basename) - 2
+ in
+ let ext =
+ String.sub basename 2 ext_len
+ in
+ let dirname =
+ Filename.dirname fn
+ in
+ Array.fold_left
+ (fun acc fn ->
+ try
+ let fn_ext =
+ String.sub
+ fn
+ ((String.length fn) - ext_len)
+ ext_len
+ in
+ if fn_ext = ext then
+ (Filename.concat dirname fn) :: acc
+ else
+ acc
+ with Invalid_argument _ ->
+ acc)
+ []
+ (Sys.readdir dirname)
+ end
+ else
+ begin
+ if file_exists_case fn then
+ [fn]
+ else
+ []
+ end
+end
+
+
+# 2916 "setup.ml"
+module BaseEnvLight = struct
+(* # 22 "src/base/BaseEnvLight.ml" *)
+
+
+ module MapString = Map.Make(String)
+
+
+ type t = string MapString.t
+
+
+ let default_filename =
+ Filename.concat
+ (Sys.getcwd ())
+ "setup.data"
+
+
+ let load ?(allow_empty=false) ?(filename=default_filename) () =
+ if Sys.file_exists filename then
+ begin
+ let chn =
+ open_in_bin filename
+ in
+ let st =
+ Stream.of_channel chn
+ in
+ let line =
+ ref 1
+ in
+ let st_line =
+ Stream.from
+ (fun _ ->
+ try
+ match Stream.next st with
+ | '\n' -> incr line; Some '\n'
+ | c -> Some c
+ with Stream.Failure -> None)
+ in
+ let lexer =
+ Genlex.make_lexer ["="] st_line
+ in
+ let rec read_file mp =
+ match Stream.npeek 3 lexer with
+ | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] ->
+ Stream.junk lexer;
+ Stream.junk lexer;
+ Stream.junk lexer;
+ read_file (MapString.add nm value mp)
+ | [] ->
+ mp
+ | _ ->
+ failwith
+ (Printf.sprintf
+ "Malformed data file '%s' line %d"
+ filename !line)
+ in
+ let mp =
+ read_file MapString.empty
+ in
+ close_in chn;
+ mp
+ end
+ else if allow_empty then
+ begin
+ MapString.empty
+ end
+ else
+ begin
+ failwith
+ (Printf.sprintf
+ "Unable to load environment, the file '%s' doesn't exist."
+ filename)
+ end
+
+
+ let rec var_expand str env =
+ let buff =
+ Buffer.create ((String.length str) * 2)
+ in
+ Buffer.add_substitute
+ buff
+ (fun var ->
+ try
+ var_expand (MapString.find var env) env
+ with Not_found ->
+ failwith
+ (Printf.sprintf
+ "No variable %s defined when trying to expand %S."
+ var
+ str))
+ str;
+ Buffer.contents buff
+
+
+ let var_get name env =
+ var_expand (MapString.find name env) env
+
+
+ let var_choose lst env =
+ OASISExpr.choose
+ (fun nm -> var_get nm env)
+ lst
+end
+
+
+# 3021 "setup.ml"
+module BaseContext = struct
+(* # 22 "src/base/BaseContext.ml" *)
+
+ (* TODO: get rid of this module. *)
+ open OASISContext
+
+
+ let args () = fst (fspecs ())
+
+
+ let default = default
+
+end
+
+module BaseMessage = struct
+(* # 22 "src/base/BaseMessage.ml" *)
+
+
+ (** Message to user, overrid for Base
+ @author Sylvain Le Gall
+ *)
+ open OASISMessage
+ open BaseContext
+
+
+ let debug fmt = debug ~ctxt:!default fmt
+
+
+ let info fmt = info ~ctxt:!default fmt
+
+
+ let warning fmt = warning ~ctxt:!default fmt
+
+
+ let error fmt = error ~ctxt:!default fmt
+
+end
+
+module BaseEnv = struct
+(* # 22 "src/base/BaseEnv.ml" *)
+
+ open OASISGettext
+ open OASISUtils
+ open PropList
+
+
+ module MapString = BaseEnvLight.MapString
+
+
+ type origin_t =
+ | ODefault
+ | OGetEnv
+ | OFileLoad
+ | OCommandLine
+
+
+ type cli_handle_t =
+ | CLINone
+ | CLIAuto
+ | CLIWith
+ | CLIEnable
+ | CLIUser of (Arg.key * Arg.spec * Arg.doc) list
+
+
+ type definition_t =
+ {
+ hide: bool;
+ dump: bool;
+ cli: cli_handle_t;
+ arg_help: string option;
+ group: string option;
+ }
+
+
+ let schema =
+ Schema.create "environment"
+
+
+ (* Environment data *)
+ let env =
+ Data.create ()
+
+
+ (* Environment data from file *)
+ let env_from_file =
+ ref MapString.empty
+
+
+ (* Lexer for var *)
+ let var_lxr =
+ Genlex.make_lexer []
+
+
+ let rec var_expand str =
+ let buff =
+ Buffer.create ((String.length str) * 2)
+ in
+ Buffer.add_substitute
+ buff
+ (fun var ->
+ try
+ (* TODO: this is a quick hack to allow calling Test.Command
+ * without defining executable name really. I.e. if there is
+ * an exec Executable toto, then $(toto) should be replace
+ * by its real name. It is however useful to have this function
+ * for other variable that depend on the host and should be
+ * written better than that.
+ *)
+ let st =
+ var_lxr (Stream.of_string var)
+ in
+ match Stream.npeek 3 st with
+ | [Genlex.Ident "utoh"; Genlex.Ident nm] ->
+ OASISHostPath.of_unix (var_get nm)
+ | [Genlex.Ident "utoh"; Genlex.String s] ->
+ OASISHostPath.of_unix s
+ | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] ->
+ String.escaped (var_get nm)
+ | [Genlex.Ident "ocaml_escaped"; Genlex.String s] ->
+ String.escaped s
+ | [Genlex.Ident nm] ->
+ var_get nm
+ | _ ->
+ failwithf
+ (f_ "Unknown expression '%s' in variable expansion of %s.")
+ var
+ str
+ with
+ | Unknown_field (_, _) ->
+ failwithf
+ (f_ "No variable %s defined when trying to expand %S.")
+ var
+ str
+ | Stream.Error e ->
+ failwithf
+ (f_ "Syntax error when parsing '%s' when trying to \
+ expand %S: %s")
+ var
+ str
+ e)
+ str;
+ Buffer.contents buff
+
+
+ and var_get name =
+ let vl =
+ try
+ Schema.get schema env name
+ with Unknown_field _ as e ->
+ begin
+ try
+ MapString.find name !env_from_file
+ with Not_found ->
+ raise e
+ end
+ in
+ var_expand vl
+
+
+ let var_choose ?printer ?name lst =
+ OASISExpr.choose
+ ?printer
+ ?name
+ var_get
+ lst
+
+
+ let var_protect vl =
+ let buff =
+ Buffer.create (String.length vl)
+ in
+ String.iter
+ (function
+ | '$' -> Buffer.add_string buff "\\$"
+ | c -> Buffer.add_char buff c)
+ vl;
+ Buffer.contents buff
+
+
+ let var_define
+ ?(hide=false)
+ ?(dump=true)
+ ?short_desc
+ ?(cli=CLINone)
+ ?arg_help
+ ?group
+ name (* TODO: type constraint on the fact that name must be a valid OCaml
+ id *)
+ dflt =
+
+ let default =
+ [
+ OFileLoad, (fun () -> MapString.find name !env_from_file);
+ ODefault, dflt;
+ OGetEnv, (fun () -> Sys.getenv name);
+ ]
+ in
+
+ let extra =
+ {
+ hide = hide;
+ dump = dump;
+ cli = cli;
+ arg_help = arg_help;
+ group = group;
+ }
+ in
+
+ (* Try to find a value that can be defined
+ *)
+ let var_get_low lst =
+ let errors, res =
+ List.fold_left
+ (fun (errors, res) (o, v) ->
+ if res = None then
+ begin
+ try
+ errors, Some (v ())
+ with
+ | Not_found ->
+ errors, res
+ | Failure rsn ->
+ (rsn :: errors), res
+ | e ->
+ (Printexc.to_string e) :: errors, res
+ end
+ else
+ errors, res)
+ ([], None)
+ (List.sort
+ (fun (o1, _) (o2, _) ->
+ Pervasives.compare o2 o1)
+ lst)
+ in
+ match res, errors with
+ | Some v, _ ->
+ v
+ | None, [] ->
+ raise (Not_set (name, None))
+ | None, lst ->
+ raise (Not_set (name, Some (String.concat (s_ ", ") lst)))
+ in
+
+ let help =
+ match short_desc with
+ | Some fs -> Some fs
+ | None -> None
+ in
+
+ let var_get_lst =
+ FieldRO.create
+ ~schema
+ ~name
+ ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s])
+ ~print:var_get_low
+ ~default
+ ~update:(fun ?context x old_x -> x @ old_x)
+ ?help
+ extra
+ in
+
+ fun () ->
+ var_expand (var_get_low (var_get_lst env))
+
+
+ let var_redefine
+ ?hide
+ ?dump
+ ?short_desc
+ ?cli
+ ?arg_help
+ ?group
+ name
+ dflt =
+ if Schema.mem schema name then
+ begin
+ (* TODO: look suspsicious, we want to memorize dflt not dflt () *)
+ Schema.set schema env ~context:ODefault name (dflt ());
+ fun () -> var_get name
+ end
+ else
+ begin
+ var_define
+ ?hide
+ ?dump
+ ?short_desc
+ ?cli
+ ?arg_help
+ ?group
+ name
+ dflt
+ end
+
+
+ let var_ignore (e: unit -> string) = ()
+
+
+ let print_hidden =
+ var_define
+ ~hide:true
+ ~dump:false
+ ~cli:CLIAuto
+ ~arg_help:"Print even non-printable variable. (debug)"
+ "print_hidden"
+ (fun () -> "false")
+
+
+ let var_all () =
+ List.rev
+ (Schema.fold
+ (fun acc nm def _ ->
+ if not def.hide || bool_of_string (print_hidden ()) then
+ nm :: acc
+ else
+ acc)
+ []
+ schema)
+
+
+ let default_filename =
+ BaseEnvLight.default_filename
+
+
+ let load ?allow_empty ?filename () =
+ env_from_file := BaseEnvLight.load ?allow_empty ?filename ()
+
+
+ let unload () =
+ env_from_file := MapString.empty;
+ Data.clear env
+
+
+ let dump ?(filename=default_filename) () =
+ let chn =
+ open_out_bin filename
+ in
+ let output nm value =
+ Printf.fprintf chn "%s=%S\n" nm value
+ in
+ let mp_todo =
+ (* Dump data from schema *)
+ Schema.fold
+ (fun mp_todo nm def _ ->
+ if def.dump then
+ begin
+ try
+ let value =
+ Schema.get
+ schema
+ env
+ nm
+ in
+ output nm value
+ with Not_set _ ->
+ ()
+ end;
+ MapString.remove nm mp_todo)
+ !env_from_file
+ schema
+ in
+ (* Dump data defined outside of schema *)
+ MapString.iter output mp_todo;
+
+ (* End of the dump *)
+ close_out chn
+
+
+ let print () =
+ let printable_vars =
+ Schema.fold
+ (fun acc nm def short_descr_opt ->
+ if not def.hide || bool_of_string (print_hidden ()) then
+ begin
+ try
+ let value =
+ Schema.get
+ schema
+ env
+ nm
+ in
+ let txt =
+ match short_descr_opt with
+ | Some s -> s ()
+ | None -> nm
+ in
+ (txt, value) :: acc
+ with Not_set _ ->
+ acc
+ end
+ else
+ acc)
+ []
+ schema
+ in
+ let max_length =
+ List.fold_left max 0
+ (List.rev_map String.length
+ (List.rev_map fst printable_vars))
+ in
+ let dot_pad str =
+ String.make ((max_length - (String.length str)) + 3) '.'
+ in
+
+ Printf.printf "\nConfiguration: \n";
+ List.iter
+ (fun (name, value) ->
+ Printf.printf "%s: %s %s\n" name (dot_pad name) value)
+ (List.rev printable_vars);
+ Printf.printf "\n%!"
+
+
+ let args () =
+ let arg_concat =
+ OASISUtils.varname_concat ~hyphen:'-'
+ in
+ [
+ "--override",
+ Arg.Tuple
+ (
+ let rvr = ref ""
+ in
+ let rvl = ref ""
+ in
+ [
+ Arg.Set_string rvr;
+ Arg.Set_string rvl;
+ Arg.Unit
+ (fun () ->
+ Schema.set
+ schema
+ env
+ ~context:OCommandLine
+ !rvr
+ !rvl)
+ ]
+ ),
+ "var+val Override any configuration variable.";
+
+ ]
+ @
+ List.flatten
+ (Schema.fold
+ (fun acc name def short_descr_opt ->
+ let var_set s =
+ Schema.set
+ schema
+ env
+ ~context:OCommandLine
+ name
+ s
+ in
+
+ let arg_name =
+ OASISUtils.varname_of_string ~hyphen:'-' name
+ in
+
+ let hlp =
+ match short_descr_opt with
+ | Some txt -> txt ()
+ | None -> ""
+ in
+
+ let arg_hlp =
+ match def.arg_help with
+ | Some s -> s
+ | None -> "str"
+ in
+
+ let default_value =
+ try
+ Printf.sprintf
+ (f_ " [%s]")
+ (Schema.get
+ schema
+ env
+ name)
+ with Not_set _ ->
+ ""
+ in
+
+ let args =
+ match def.cli with
+ | CLINone ->
+ []
+ | CLIAuto ->
+ [
+ arg_concat "--" arg_name,
+ Arg.String var_set,
+ Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
+ ]
+ | CLIWith ->
+ [
+ arg_concat "--with-" arg_name,
+ Arg.String var_set,
+ Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value
+ ]
+ | CLIEnable ->
+ let dflt =
+ if default_value = " [true]" then
+ s_ " [default: enabled]"
+ else
+ s_ " [default: disabled]"
+ in
+ [
+ arg_concat "--enable-" arg_name,
+ Arg.Unit (fun () -> var_set "true"),
+ Printf.sprintf (f_ " %s%s") hlp dflt;
+
+ arg_concat "--disable-" arg_name,
+ Arg.Unit (fun () -> var_set "false"),
+ Printf.sprintf (f_ " %s%s") hlp dflt
+ ]
+ | CLIUser lst ->
+ lst
+ in
+ args :: acc)
+ []
+ schema)
+end
+
+module BaseArgExt = struct
+(* # 22 "src/base/BaseArgExt.ml" *)
+
+
+ open OASISUtils
+ open OASISGettext
+
+
+ let parse argv args =
+ (* Simulate command line for Arg *)
+ let current =
+ ref 0
+ in
+
+ try
+ Arg.parse_argv
+ ~current:current
+ (Array.concat [[|"none"|]; argv])
+ (Arg.align args)
+ (failwithf (f_ "Don't know what to do with arguments: '%s'"))
+ (s_ "configure options:")
+ with
+ | Arg.Help txt ->
+ print_endline txt;
+ exit 0
+ | Arg.Bad txt ->
+ prerr_endline txt;
+ exit 1
+end
+
+module BaseCheck = struct
+(* # 22 "src/base/BaseCheck.ml" *)
+
+
+ open BaseEnv
+ open BaseMessage
+ open OASISUtils
+ open OASISGettext
+
+
+ let prog_best prg prg_lst =
+ var_redefine
+ prg
+ (fun () ->
+ let alternate =
+ List.fold_left
+ (fun res e ->
+ match res with
+ | Some _ ->
+ res
+ | None ->
+ try
+ Some (OASISFileUtil.which ~ctxt:!BaseContext.default e)
+ with Not_found ->
+ None)
+ None
+ prg_lst
+ in
+ match alternate with
+ | Some prg -> prg
+ | None -> raise Not_found)
+
+
+ let prog prg =
+ prog_best prg [prg]
+
+
+ let prog_opt prg =
+ prog_best prg [prg^".opt"; prg]
+
+
+ let ocamlfind =
+ prog "ocamlfind"
+
+
+ let version
+ var_prefix
+ cmp
+ fversion
+ () =
+ (* Really compare version provided *)
+ let var =
+ var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp)
+ in
+ var_redefine
+ ~hide:true
+ var
+ (fun () ->
+ let version_str =
+ match fversion () with
+ | "[Distributed with OCaml]" ->
+ begin
+ try
+ (var_get "ocaml_version")
+ with Not_found ->
+ warning
+ (f_ "Variable ocaml_version not defined, fallback \
+ to default");
+ Sys.ocaml_version
+ end
+ | res ->
+ res
+ in
+ let version =
+ OASISVersion.version_of_string version_str
+ in
+ if OASISVersion.comparator_apply version cmp then
+ version_str
+ else
+ failwithf
+ (f_ "Cannot satisfy version constraint on %s: %s (version: %s)")
+ var_prefix
+ (OASISVersion.string_of_comparator cmp)
+ version_str)
+ ()
+
+
+ let package_version pkg =
+ OASISExec.run_read_one_line ~ctxt:!BaseContext.default
+ (ocamlfind ())
+ ["query"; "-format"; "%v"; pkg]
+
+
+ let package ?version_comparator pkg () =
+ let var =
+ OASISUtils.varname_concat
+ "pkg_"
+ (OASISUtils.varname_of_string pkg)
+ in
+ let findlib_dir pkg =
+ let dir =
+ OASISExec.run_read_one_line ~ctxt:!BaseContext.default
+ (ocamlfind ())
+ ["query"; "-format"; "%d"; pkg]
+ in
+ if Sys.file_exists dir && Sys.is_directory dir then
+ dir
+ else
+ failwithf
+ (f_ "When looking for findlib package %s, \
+ directory %s return doesn't exist")
+ pkg dir
+ in
+ let vl =
+ var_redefine
+ var
+ (fun () -> findlib_dir pkg)
+ ()
+ in
+ (
+ match version_comparator with
+ | Some ver_cmp ->
+ ignore
+ (version
+ var
+ ver_cmp
+ (fun _ -> package_version pkg)
+ ())
+ | None ->
+ ()
+ );
+ vl
+end
+
+module BaseOCamlcConfig = struct
+(* # 22 "src/base/BaseOCamlcConfig.ml" *)
+
+
+ open BaseEnv
+ open OASISUtils
+ open OASISGettext
+
+
+ module SMap = Map.Make(String)
+
+
+ let ocamlc =
+ BaseCheck.prog_opt "ocamlc"
+
+
+ let ocamlc_config_map =
+ (* Map name to value for ocamlc -config output
+ (name ^": "^value)
+ *)
+ let rec split_field mp lst =
+ match lst with
+ | line :: tl ->
+ let mp =
+ try
+ let pos_semicolon =
+ String.index line ':'
+ in
+ if pos_semicolon > 1 then
+ (
+ let name =
+ String.sub line 0 pos_semicolon
+ in
+ let linelen =
+ String.length line
+ in
+ let value =
+ if linelen > pos_semicolon + 2 then
+ String.sub
+ line
+ (pos_semicolon + 2)
+ (linelen - pos_semicolon - 2)
+ else
+ ""
+ in
+ SMap.add name value mp
+ )
+ else
+ (
+ mp
+ )
+ with Not_found ->
+ (
+ mp
+ )
+ in
+ split_field mp tl
+ | [] ->
+ mp
+ in
+
+ let cache =
+ lazy
+ (var_protect
+ (Marshal.to_string
+ (split_field
+ SMap.empty
+ (OASISExec.run_read_output
+ ~ctxt:!BaseContext.default
+ (ocamlc ()) ["-config"]))
+ []))
+ in
+ var_redefine
+ "ocamlc_config_map"
+ ~hide:true
+ ~dump:false
+ (fun () ->
+ (* TODO: update if ocamlc change !!! *)
+ Lazy.force cache)
+
+
+ let var_define nm =
+ (* Extract data from ocamlc -config *)
+ let avlbl_config_get () =
+ Marshal.from_string
+ (ocamlc_config_map ())
+ 0
+ in
+ let chop_version_suffix s =
+ try
+ String.sub s 0 (String.index s '+')
+ with _ ->
+ s
+ in
+
+ let nm_config, value_config =
+ match nm with
+ | "ocaml_version" ->
+ "version", chop_version_suffix
+ | _ -> nm, (fun x -> x)
+ in
+ var_redefine
+ nm
+ (fun () ->
+ try
+ let map =
+ avlbl_config_get ()
+ in
+ let value =
+ SMap.find nm_config map
+ in
+ value_config value
+ with Not_found ->
+ failwithf
+ (f_ "Cannot find field '%s' in '%s -config' output")
+ nm
+ (ocamlc ()))
+
+end
+
+module BaseStandardVar = struct
+(* # 22 "src/base/BaseStandardVar.ml" *)
+
+
+ open OASISGettext
+ open OASISTypes
+ open OASISExpr
+ open BaseCheck
+ open BaseEnv
+
+
+ let ocamlfind = BaseCheck.ocamlfind
+ let ocamlc = BaseOCamlcConfig.ocamlc
+ let ocamlopt = prog_opt "ocamlopt"
+ let ocamlbuild = prog "ocamlbuild"
+
+
+ (**/**)
+ let rpkg =
+ ref None
+
+
+ let pkg_get () =
+ match !rpkg with
+ | Some pkg -> pkg
+ | None -> failwith (s_ "OASIS Package is not set")
+
+
+ let var_cond = ref []
+
+
+ let var_define_cond ~since_version f dflt =
+ let holder = ref (fun () -> dflt) in
+ let since_version =
+ OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version)
+ in
+ var_cond :=
+ (fun ver ->
+ if OASISVersion.comparator_apply ver since_version then
+ holder := f ()) :: !var_cond;
+ fun () -> !holder ()
+
+
+ (**/**)
+
+
+ let pkg_name =
+ var_define
+ ~short_desc:(fun () -> s_ "Package name")
+ "pkg_name"
+ (fun () -> (pkg_get ()).name)
+
+
+ let pkg_version =
+ var_define
+ ~short_desc:(fun () -> s_ "Package version")
+ "pkg_version"
+ (fun () ->
+ (OASISVersion.string_of_version (pkg_get ()).version))
+
+
+ let c = BaseOCamlcConfig.var_define
+
+
+ let os_type = c "os_type"
+ let system = c "system"
+ let architecture = c "architecture"
+ let ccomp_type = c "ccomp_type"
+ let ocaml_version = c "ocaml_version"
+
+
+ (* TODO: Check standard variable presence at runtime *)
+
+
+ let standard_library_default = c "standard_library_default"
+ let standard_library = c "standard_library"
+ let standard_runtime = c "standard_runtime"
+ let bytecomp_c_compiler = c "bytecomp_c_compiler"
+ let native_c_compiler = c "native_c_compiler"
+ let model = c "model"
+ let ext_obj = c "ext_obj"
+ let ext_asm = c "ext_asm"
+ let ext_lib = c "ext_lib"
+ let ext_dll = c "ext_dll"
+ let default_executable_name = c "default_executable_name"
+ let systhread_supported = c "systhread_supported"
+
+
+ let flexlink =
+ BaseCheck.prog "flexlink"
+
+
+ let flexdll_version =
+ var_define
+ ~short_desc:(fun () -> "FlexDLL version (Win32)")
+ "flexdll_version"
+ (fun () ->
+ let lst =
+ OASISExec.run_read_output ~ctxt:!BaseContext.default
+ (flexlink ()) ["-help"]
+ in
+ match lst with
+ | line :: _ ->
+ Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver)
+ | [] ->
+ raise Not_found)
+
+
+ (**/**)
+ let p name hlp dflt =
+ var_define
+ ~short_desc:hlp
+ ~cli:CLIAuto
+ ~arg_help:"dir"
+ name
+ dflt
+
+
+ let (/) a b =
+ if os_type () = Sys.os_type then
+ Filename.concat a b
+ else if os_type () = "Unix" then
+ OASISUnixPath.concat a b
+ else
+ OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat")
+ (os_type ())
+ (**/**)
+
+
+ let prefix =
+ p "prefix"
+ (fun () -> s_ "Install architecture-independent files dir")
+ (fun () ->
+ match os_type () with
+ | "Win32" ->
+ let program_files =
+ Sys.getenv "PROGRAMFILES"
+ in
+ program_files/(pkg_name ())
+ | _ ->
+ "/usr/local")
+
+
+ let exec_prefix =
+ p "exec_prefix"
+ (fun () -> s_ "Install architecture-dependent files in dir")
+ (fun () -> "$prefix")
+
+
+ let bindir =
+ p "bindir"
+ (fun () -> s_ "User executables")
+ (fun () -> "$exec_prefix"/"bin")
+
+
+ let sbindir =
+ p "sbindir"
+ (fun () -> s_ "System admin executables")
+ (fun () -> "$exec_prefix"/"sbin")
+
+
+ let libexecdir =
+ p "libexecdir"
+ (fun () -> s_ "Program executables")
+ (fun () -> "$exec_prefix"/"libexec")
+
+
+ let sysconfdir =
+ p "sysconfdir"
+ (fun () -> s_ "Read-only single-machine data")
+ (fun () -> "$prefix"/"etc")
+
+
+ let sharedstatedir =
+ p "sharedstatedir"
+ (fun () -> s_ "Modifiable architecture-independent data")
+ (fun () -> "$prefix"/"com")
+
+
+ let localstatedir =
+ p "localstatedir"
+ (fun () -> s_ "Modifiable single-machine data")
+ (fun () -> "$prefix"/"var")
+
+
+ let libdir =
+ p "libdir"
+ (fun () -> s_ "Object code libraries")
+ (fun () -> "$exec_prefix"/"lib")
+
+
+ let datarootdir =
+ p "datarootdir"
+ (fun () -> s_ "Read-only arch-independent data root")
+ (fun () -> "$prefix"/"share")
+
+
+ let datadir =
+ p "datadir"
+ (fun () -> s_ "Read-only architecture-independent data")
+ (fun () -> "$datarootdir")
+
+
+ let infodir =
+ p "infodir"
+ (fun () -> s_ "Info documentation")
+ (fun () -> "$datarootdir"/"info")
+
+
+ let localedir =
+ p "localedir"
+ (fun () -> s_ "Locale-dependent data")
+ (fun () -> "$datarootdir"/"locale")
+
+
+ let mandir =
+ p "mandir"
+ (fun () -> s_ "Man documentation")
+ (fun () -> "$datarootdir"/"man")
+
+
+ let docdir =
+ p "docdir"
+ (fun () -> s_ "Documentation root")
+ (fun () -> "$datarootdir"/"doc"/"$pkg_name")
+
+
+ let htmldir =
+ p "htmldir"
+ (fun () -> s_ "HTML documentation")
+ (fun () -> "$docdir")
+
+
+ let dvidir =
+ p "dvidir"
+ (fun () -> s_ "DVI documentation")
+ (fun () -> "$docdir")
+
+
+ let pdfdir =
+ p "pdfdir"
+ (fun () -> s_ "PDF documentation")
+ (fun () -> "$docdir")
+
+
+ let psdir =
+ p "psdir"
+ (fun () -> s_ "PS documentation")
+ (fun () -> "$docdir")
+
+
+ let destdir =
+ p "destdir"
+ (fun () -> s_ "Prepend a path when installing package")
+ (fun () ->
+ raise
+ (PropList.Not_set
+ ("destdir",
+ Some (s_ "undefined by construct"))))
+
+
+ let findlib_version =
+ var_define
+ "findlib_version"
+ (fun () ->
+ BaseCheck.package_version "findlib")
+
+
+ let is_native =
+ var_define
+ "is_native"
+ (fun () ->
+ try
+ let _s: string =
+ ocamlopt ()
+ in
+ "true"
+ with PropList.Not_set _ ->
+ let _s: string =
+ ocamlc ()
+ in
+ "false")
+
+
+ let ext_program =
+ var_define
+ "suffix_program"
+ (fun () ->
+ match os_type () with
+ | "Win32" | "Cygwin" -> ".exe"
+ | _ -> "")
+
+
+ let rm =
+ var_define
+ ~short_desc:(fun () -> s_ "Remove a file.")
+ "rm"
+ (fun () ->
+ match os_type () with
+ | "Win32" -> "del"
+ | _ -> "rm -f")
+
+
+ let rmdir =
+ var_define
+ ~short_desc:(fun () -> s_ "Remove a directory.")
+ "rmdir"
+ (fun () ->
+ match os_type () with
+ | "Win32" -> "rd"
+ | _ -> "rm -rf")
+
+
+ let debug =
+ var_define
+ ~short_desc:(fun () -> s_ "Turn ocaml debug flag on")
+ ~cli:CLIEnable
+ "debug"
+ (fun () -> "true")
+
+
+ let profile =
+ var_define
+ ~short_desc:(fun () -> s_ "Turn ocaml profile flag on")
+ ~cli:CLIEnable
+ "profile"
+ (fun () -> "false")
+
+
+ let tests =
+ var_define_cond ~since_version:"0.3"
+ (fun () ->
+ var_define
+ ~short_desc:(fun () ->
+ s_ "Compile tests executable and library and run them")
+ ~cli:CLIEnable
+ "tests"
+ (fun () -> "false"))
+ "true"
+
+
+ let docs =
+ var_define_cond ~since_version:"0.3"
+ (fun () ->
+ var_define
+ ~short_desc:(fun () -> s_ "Create documentations")
+ ~cli:CLIEnable
+ "docs"
+ (fun () -> "true"))
+ "true"
+
+
+ let native_dynlink =
+ var_define
+ ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.")
+ ~cli:CLINone
+ "native_dynlink"
+ (fun () ->
+ let res =
+ let ocaml_lt_312 () =
+ OASISVersion.comparator_apply
+ (OASISVersion.version_of_string (ocaml_version ()))
+ (OASISVersion.VLesser
+ (OASISVersion.version_of_string "3.12.0"))
+ in
+ let flexdll_lt_030 () =
+ OASISVersion.comparator_apply
+ (OASISVersion.version_of_string (flexdll_version ()))
+ (OASISVersion.VLesser
+ (OASISVersion.version_of_string "0.30"))
+ in
+ let has_native_dynlink =
+ let ocamlfind = ocamlfind () in
+ try
+ let fn =
+ OASISExec.run_read_one_line
+ ~ctxt:!BaseContext.default
+ ocamlfind
+ ["query"; "-predicates"; "native"; "dynlink";
+ "-format"; "%d/%a"]
+ in
+ Sys.file_exists fn
+ with _ ->
+ false
+ in
+ if not has_native_dynlink then
+ false
+ else if ocaml_lt_312 () then
+ false
+ else if (os_type () = "Win32" || os_type () = "Cygwin")
+ && flexdll_lt_030 () then
+ begin
+ BaseMessage.warning
+ (f_ ".cmxs generation disabled because FlexDLL needs to be \
+ at least 0.30. Please upgrade FlexDLL from %s to 0.30.")
+ (flexdll_version ());
+ false
+ end
+ else
+ true
+ in
+ string_of_bool res)
+
+
+ let init pkg =
+ rpkg := Some pkg;
+ List.iter (fun f -> f pkg.oasis_version) !var_cond
+
+end
+
+module BaseFileAB = struct
+(* # 22 "src/base/BaseFileAB.ml" *)
+
+
+ open BaseEnv
+ open OASISGettext
+ open BaseMessage
+
+
+ let to_filename fn =
+ let fn =
+ OASISHostPath.of_unix fn
+ in
+ if not (Filename.check_suffix fn ".ab") then
+ warning
+ (f_ "File '%s' doesn't have '.ab' extension")
+ fn;
+ Filename.chop_extension fn
+
+
+ let replace fn_lst =
+ let buff =
+ Buffer.create 13
+ in
+ List.iter
+ (fun fn ->
+ let fn =
+ OASISHostPath.of_unix fn
+ in
+ let chn_in =
+ open_in fn
+ in
+ let chn_out =
+ open_out (to_filename fn)
+ in
+ (
+ try
+ while true do
+ Buffer.add_string buff (var_expand (input_line chn_in));
+ Buffer.add_char buff '\n'
+ done
+ with End_of_file ->
+ ()
+ );
+ Buffer.output_buffer chn_out buff;
+ Buffer.clear buff;
+ close_in chn_in;
+ close_out chn_out)
+ fn_lst
+end
+
+module BaseLog = struct
+(* # 22 "src/base/BaseLog.ml" *)
+
+
+ open OASISUtils
+
+
+ let default_filename =
+ Filename.concat
+ (Filename.dirname BaseEnv.default_filename)
+ "setup.log"
+
+
+ module SetTupleString =
+ Set.Make
+ (struct
+ type t = string * string
+ let compare (s11, s12) (s21, s22) =
+ match String.compare s11 s21 with
+ | 0 -> String.compare s12 s22
+ | n -> n
+ end)
+
+
+ let load () =
+ if Sys.file_exists default_filename then
+ begin
+ let chn =
+ open_in default_filename
+ in
+ let scbuf =
+ Scanf.Scanning.from_file default_filename
+ in
+ let rec read_aux (st, lst) =
+ if not (Scanf.Scanning.end_of_input scbuf) then
+ begin
+ let acc =
+ try
+ Scanf.bscanf scbuf "%S %S\n"
+ (fun e d ->
+ let t =
+ e, d
+ in
+ if SetTupleString.mem t st then
+ st, lst
+ else
+ SetTupleString.add t st,
+ t :: lst)
+ with Scanf.Scan_failure _ ->
+ failwith
+ (Scanf.bscanf scbuf
+ "%l"
+ (fun line ->
+ Printf.sprintf
+ "Malformed log file '%s' at line %d"
+ default_filename
+ line))
+ in
+ read_aux acc
+ end
+ else
+ begin
+ close_in chn;
+ List.rev lst
+ end
+ in
+ read_aux (SetTupleString.empty, [])
+ end
+ else
+ begin
+ []
+ end
+
+
+ let register event data =
+ let chn_out =
+ open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename
+ in
+ Printf.fprintf chn_out "%S %S\n" event data;
+ close_out chn_out
+
+
+ let unregister event data =
+ if Sys.file_exists default_filename then
+ begin
+ let lst =
+ load ()
+ in
+ let chn_out =
+ open_out default_filename
+ in
+ let write_something =
+ ref false
+ in
+ List.iter
+ (fun (e, d) ->
+ if e <> event || d <> data then
+ begin
+ write_something := true;
+ Printf.fprintf chn_out "%S %S\n" e d
+ end)
+ lst;
+ close_out chn_out;
+ if not !write_something then
+ Sys.remove default_filename
+ end
+
+
+ let filter events =
+ let st_events =
+ List.fold_left
+ (fun st e ->
+ SetString.add e st)
+ SetString.empty
+ events
+ in
+ List.filter
+ (fun (e, _) -> SetString.mem e st_events)
+ (load ())
+
+
+ let exists event data =
+ List.exists
+ (fun v -> (event, data) = v)
+ (load ())
+end
+
+module BaseBuilt = struct
+(* # 22 "src/base/BaseBuilt.ml" *)
+
+
+ open OASISTypes
+ open OASISGettext
+ open BaseStandardVar
+ open BaseMessage
+
+
+ type t =
+ | BExec (* Executable *)
+ | BExecLib (* Library coming with executable *)
+ | BLib (* Library *)
+ | BObj (* Library *)
+ | BDoc (* Document *)
+
+
+ let to_log_event_file t nm =
+ "built_"^
+ (match t with
+ | BExec -> "exec"
+ | BExecLib -> "exec_lib"
+ | BLib -> "lib"
+ | BObj -> "obj"
+ | BDoc -> "doc")^
+ "_"^nm
+
+
+ let to_log_event_done t nm =
+ "is_"^(to_log_event_file t nm)
+
+
+ let register t nm lst =
+ BaseLog.register
+ (to_log_event_done t nm)
+ "true";
+ List.iter
+ (fun alt ->
+ let registered =
+ List.fold_left
+ (fun registered fn ->
+ if OASISFileUtil.file_exists_case fn then
+ begin
+ BaseLog.register
+ (to_log_event_file t nm)
+ (if Filename.is_relative fn then
+ Filename.concat (Sys.getcwd ()) fn
+ else
+ fn);
+ true
+ end
+ else
+ registered)
+ false
+ alt
+ in
+ if not registered then
+ warning
+ (f_ "Cannot find an existing alternative files among: %s")
+ (String.concat (s_ ", ") alt))
+ lst
+
+
+ let unregister t nm =
+ List.iter
+ (fun (e, d) ->
+ BaseLog.unregister e d)
+ (BaseLog.filter
+ [to_log_event_file t nm;
+ to_log_event_done t nm])
+
+
+ let fold t nm f acc =
+ List.fold_left
+ (fun acc (_, fn) ->
+ if OASISFileUtil.file_exists_case fn then
+ begin
+ f acc fn
+ end
+ else
+ begin
+ warning
+ (f_ "File '%s' has been marked as built \
+ for %s but doesn't exist")
+ fn
+ (Printf.sprintf
+ (match t with
+ | BExec | BExecLib ->
+ (f_ "executable %s")
+ | BLib ->
+ (f_ "library %s")
+ | BObj ->
+ (f_ "object %s")
+ | BDoc ->
+ (f_ "documentation %s"))
+ nm);
+ acc
+ end)
+ acc
+ (BaseLog.filter
+ [to_log_event_file t nm])
+
+
+ let is_built t nm =
+ List.fold_left
+ (fun is_built (_, d) ->
+ (try
+ bool_of_string d
+ with _ ->
+ false))
+ false
+ (BaseLog.filter
+ [to_log_event_done t nm])
+
+
+ let of_executable ffn (cs, bs, exec) =
+ let unix_exec_is, unix_dll_opt =
+ OASISExecutable.unix_exec_is
+ (cs, bs, exec)
+ (fun () ->
+ bool_of_string
+ (is_native ()))
+ ext_dll
+ ext_program
+ in
+ let evs =
+ (BExec, cs.cs_name, [[ffn unix_exec_is]])
+ ::
+ (match unix_dll_opt with
+ | Some fn ->
+ [BExecLib, cs.cs_name, [[ffn fn]]]
+ | None ->
+ [])
+ in
+ evs,
+ unix_exec_is,
+ unix_dll_opt
+
+
+ let of_library ffn (cs, bs, lib) =
+ let unix_lst =
+ OASISLibrary.generated_unix_files
+ ~ctxt:!BaseContext.default
+ ~source_file_exists:(fun fn ->
+ OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn))
+ ~is_native:(bool_of_string (is_native ()))
+ ~has_native_dynlink:(bool_of_string (native_dynlink ()))
+ ~ext_lib:(ext_lib ())
+ ~ext_dll:(ext_dll ())
+ (cs, bs, lib)
+ in
+ let evs =
+ [BLib,
+ cs.cs_name,
+ List.map (List.map ffn) unix_lst]
+ in
+ evs, unix_lst
+
+
+ let of_object ffn (cs, bs, obj) =
+ let unix_lst =
+ OASISObject.generated_unix_files
+ ~ctxt:!BaseContext.default
+ ~source_file_exists:(fun fn ->
+ OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn))
+ ~is_native:(bool_of_string (is_native ()))
+ (cs, bs, obj)
+ in
+ let evs =
+ [BObj,
+ cs.cs_name,
+ List.map (List.map ffn) unix_lst]
+ in
+ evs, unix_lst
+
+end
+
+module BaseCustom = struct
+(* # 22 "src/base/BaseCustom.ml" *)
+
+
+ open BaseEnv
+ open BaseMessage
+ open OASISTypes
+ open OASISGettext
+
+
+ let run cmd args extra_args =
+ OASISExec.run ~ctxt:!BaseContext.default ~quote:false
+ (var_expand cmd)
+ (List.map
+ var_expand
+ (args @ (Array.to_list extra_args)))
+
+
+ let hook ?(failsafe=false) cstm f e =
+ let optional_command lst =
+ let printer =
+ function
+ | Some (cmd, args) -> String.concat " " (cmd :: args)
+ | None -> s_ "No command"
+ in
+ match
+ var_choose
+ ~name:(s_ "Pre/Post Command")
+ ~printer
+ lst with
+ | Some (cmd, args) ->
+ begin
+ try
+ run cmd args [||]
+ with e when failsafe ->
+ warning
+ (f_ "Command '%s' fail with error: %s")
+ (String.concat " " (cmd :: args))
+ (match e with
+ | Failure msg -> msg
+ | e -> Printexc.to_string e)
+ end
+ | None ->
+ ()
+ in
+ let res =
+ optional_command cstm.pre_command;
+ f e
+ in
+ optional_command cstm.post_command;
+ res
+end
+
+module BaseDynVar = struct
+(* # 22 "src/base/BaseDynVar.ml" *)
+
+
+ open OASISTypes
+ open OASISGettext
+ open BaseEnv
+ open BaseBuilt
+
+
+ let init pkg =
+ (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *)
+ (* TODO: provide compile option for library libary_byte_args_VARNAME... *)
+ List.iter
+ (function
+ | Executable (cs, bs, exec) ->
+ if var_choose bs.bs_build then
+ var_ignore
+ (var_redefine
+ (* We don't save this variable *)
+ ~dump:false
+ ~short_desc:(fun () ->
+ Printf.sprintf
+ (f_ "Filename of executable '%s'")
+ cs.cs_name)
+ (OASISUtils.varname_of_string cs.cs_name)
+ (fun () ->
+ let fn_opt =
+ fold
+ BExec cs.cs_name
+ (fun _ fn -> Some fn)
+ None
+ in
+ match fn_opt with
+ | Some fn -> fn
+ | None ->
+ raise
+ (PropList.Not_set
+ (cs.cs_name,
+ Some (Printf.sprintf
+ (f_ "Executable '%s' not yet built.")
+ cs.cs_name)))))
+
+ | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ ->
+ ())
+ pkg.sections
+end
+
+module BaseTest = struct
+(* # 22 "src/base/BaseTest.ml" *)
+
+
+ open BaseEnv
+ open BaseMessage
+ open OASISTypes
+ open OASISExpr
+ open OASISGettext
+
+
+ let test lst pkg extra_args =
+
+ let one_test (failure, n) (test_plugin, cs, test) =
+ if var_choose
+ ~name:(Printf.sprintf
+ (f_ "test %s run")
+ cs.cs_name)
+ ~printer:string_of_bool
+ test.test_run then
+ begin
+ let () =
+ info (f_ "Running test '%s'") cs.cs_name
+ in
+ let back_cwd =
+ match test.test_working_directory with
+ | Some dir ->
+ let cwd =
+ Sys.getcwd ()
+ in
+ let chdir d =
+ info (f_ "Changing directory to '%s'") d;
+ Sys.chdir d
+ in
+ chdir dir;
+ fun () -> chdir cwd
+
+ | None ->
+ fun () -> ()
+ in
+ try
+ let failure_percent =
+ BaseCustom.hook
+ test.test_custom
+ (test_plugin pkg (cs, test))
+ extra_args
+ in
+ back_cwd ();
+ (failure_percent +. failure, n + 1)
+ with e ->
+ begin
+ back_cwd ();
+ raise e
+ end
+ end
+ else
+ begin
+ info (f_ "Skipping test '%s'") cs.cs_name;
+ (failure, n)
+ end
+ in
+ let failed, n =
+ List.fold_left
+ one_test
+ (0.0, 0)
+ lst
+ in
+ let failure_percent =
+ if n = 0 then
+ 0.0
+ else
+ failed /. (float_of_int n)
+ in
+ let msg =
+ Printf.sprintf
+ (f_ "Tests had a %.2f%% failure rate")
+ (100. *. failure_percent)
+ in
+ if failure_percent > 0.0 then
+ failwith msg
+ else
+ info "%s" msg;
+
+ (* Possible explanation why the tests where not run. *)
+ if OASISFeatures.package_test OASISFeatures.flag_tests pkg &&
+ not (bool_of_string (BaseStandardVar.tests ())) &&
+ lst <> [] then
+ BaseMessage.warning
+ "Tests are turned off, consider enabling with \
+ 'ocaml setup.ml -configure --enable-tests'"
+end
+
+module BaseDoc = struct
+(* # 22 "src/base/BaseDoc.ml" *)
+
+
+ open BaseEnv
+ open BaseMessage
+ open OASISTypes
+ open OASISGettext
+
+
+ let doc lst pkg extra_args =
+
+ let one_doc (doc_plugin, cs, doc) =
+ if var_choose
+ ~name:(Printf.sprintf
+ (f_ "documentation %s build")
+ cs.cs_name)
+ ~printer:string_of_bool
+ doc.doc_build then
+ begin
+ info (f_ "Building documentation '%s'") cs.cs_name;
+ BaseCustom.hook
+ doc.doc_custom
+ (doc_plugin pkg (cs, doc))
+ extra_args
+ end
+ in
+ List.iter one_doc lst;
+
+ if OASISFeatures.package_test OASISFeatures.flag_docs pkg &&
+ not (bool_of_string (BaseStandardVar.docs ())) &&
+ lst <> [] then
+ BaseMessage.warning
+ "Docs are turned off, consider enabling with \
+ 'ocaml setup.ml -configure --enable-docs'"
+end
+
+module BaseSetup = struct
+(* # 22 "src/base/BaseSetup.ml" *)
+
+ open BaseEnv
+ open BaseMessage
+ open OASISTypes
+ open OASISSection
+ open OASISGettext
+ open OASISUtils
+
+
+ type std_args_fun =
+ package -> string array -> unit
+
+
+ type ('a, 'b) section_args_fun =
+ name * (package -> (common_section * 'a) -> string array -> 'b)
+
+
+ type t =
+ {
+ configure: std_args_fun;
+ build: std_args_fun;
+ doc: ((doc, unit) section_args_fun) list;
+ test: ((test, float) section_args_fun) list;
+ install: std_args_fun;
+ uninstall: std_args_fun;
+ clean: std_args_fun list;
+ clean_doc: (doc, unit) section_args_fun list;
+ clean_test: (test, unit) section_args_fun list;
+ distclean: std_args_fun list;
+ distclean_doc: (doc, unit) section_args_fun list;
+ distclean_test: (test, unit) section_args_fun list;
+ package: package;
+ oasis_fn: string option;
+ oasis_version: string;
+ oasis_digest: Digest.t option;
+ oasis_exec: string option;
+ oasis_setup_args: string list;
+ setup_update: bool;
+ }
+
+
+ (* Associate a plugin function with data from package *)
+ let join_plugin_sections filter_map lst =
+ List.rev
+ (List.fold_left
+ (fun acc sct ->
+ match filter_map sct with
+ | Some e ->
+ e :: acc
+ | None ->
+ acc)
+ []
+ lst)
+
+
+ (* Search for plugin data associated with a section name *)
+ let lookup_plugin_section plugin action nm lst =
+ try
+ List.assoc nm lst
+ with Not_found ->
+ failwithf
+ (f_ "Cannot find plugin %s matching section %s for %s action")
+ plugin
+ nm
+ action
+
+
+ let configure t args =
+ (* Run configure *)
+ BaseCustom.hook
+ t.package.conf_custom
+ (fun () ->
+ (* Reload if preconf has changed it *)
+ begin
+ try
+ unload ();
+ load ();
+ with _ ->
+ ()
+ end;
+
+ (* Run plugin's configure *)
+ t.configure t.package args;
+
+ (* Dump to allow postconf to change it *)
+ dump ())
+ ();
+
+ (* Reload environment *)
+ unload ();
+ load ();
+
+ (* Save environment *)
+ print ();
+
+ (* Replace data in file *)
+ BaseFileAB.replace t.package.files_ab
+
+
+ let build t args =
+ BaseCustom.hook
+ t.package.build_custom
+ (t.build t.package)
+ args
+
+
+ let doc t args =
+ BaseDoc.doc
+ (join_plugin_sections
+ (function
+ | Doc (cs, e) ->
+ Some
+ (lookup_plugin_section
+ "documentation"
+ (s_ "build")
+ cs.cs_name
+ t.doc,
+ cs,
+ e)
+ | _ ->
+ None)
+ t.package.sections)
+ t.package
+ args
+
+
+ let test t args =
+ BaseTest.test
+ (join_plugin_sections
+ (function
+ | Test (cs, e) ->
+ Some
+ (lookup_plugin_section
+ "test"
+ (s_ "run")
+ cs.cs_name
+ t.test,
+ cs,
+ e)
+ | _ ->
+ None)
+ t.package.sections)
+ t.package
+ args
+
+
+ let all t args =
+ let rno_doc =
+ ref false
+ in
+ let rno_test =
+ ref false
+ in
+ let arg_rest =
+ ref []
+ in
+ Arg.parse_argv
+ ~current:(ref 0)
+ (Array.of_list
+ ((Sys.executable_name^" all") ::
+ (Array.to_list args)))
+ [
+ "-no-doc",
+ Arg.Set rno_doc,
+ s_ "Don't run doc target";
+
+ "-no-test",
+ Arg.Set rno_test,
+ s_ "Don't run test target";
+
+ "--",
+ Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest),
+ s_ "All arguments for configure.";
+ ]
+ (failwithf (f_ "Don't know what to do with '%s'"))
+ "";
+
+ info "Running configure step";
+ configure t (Array.of_list (List.rev !arg_rest));
+
+ info "Running build step";
+ build t [||];
+
+ (* Load setup.log dynamic variables *)
+ BaseDynVar.init t.package;
+
+ if not !rno_doc then
+ begin
+ info "Running doc step";
+ doc t [||];
+ end
+ else
+ begin
+ info "Skipping doc step"
+ end;
+
+ if not !rno_test then
+ begin
+ info "Running test step";
+ test t [||]
+ end
+ else
+ begin
+ info "Skipping test step"
+ end
+
+
+ let install t args =
+ BaseCustom.hook
+ t.package.install_custom
+ (t.install t.package)
+ args
+
+
+ let uninstall t args =
+ BaseCustom.hook
+ t.package.uninstall_custom
+ (t.uninstall t.package)
+ args
+
+
+ let reinstall t args =
+ uninstall t args;
+ install t args
+
+
+ let clean, distclean =
+ let failsafe f a =
+ try
+ f a
+ with e ->
+ warning
+ (f_ "Action fail with error: %s")
+ (match e with
+ | Failure msg -> msg
+ | e -> Printexc.to_string e)
+ in
+
+ let generic_clean t cstm mains docs tests args =
+ BaseCustom.hook
+ ~failsafe:true
+ cstm
+ (fun () ->
+ (* Clean section *)
+ List.iter
+ (function
+ | Test (cs, test) ->
+ let f =
+ try
+ List.assoc cs.cs_name tests
+ with Not_found ->
+ fun _ _ _ -> ()
+ in
+ failsafe
+ (f t.package (cs, test))
+ args
+ | Doc (cs, doc) ->
+ let f =
+ try
+ List.assoc cs.cs_name docs
+ with Not_found ->
+ fun _ _ _ -> ()
+ in
+ failsafe
+ (f t.package (cs, doc))
+ args
+ | Library _
+ | Object _
+ | Executable _
+ | Flag _
+ | SrcRepo _ ->
+ ())
+ t.package.sections;
+ (* Clean whole package *)
+ List.iter
+ (fun f ->
+ failsafe
+ (f t.package)
+ args)
+ mains)
+ ()
+ in
+
+ let clean t args =
+ generic_clean
+ t
+ t.package.clean_custom
+ t.clean
+ t.clean_doc
+ t.clean_test
+ args
+ in
+
+ let distclean t args =
+ (* Call clean *)
+ clean t args;
+
+ (* Call distclean code *)
+ generic_clean
+ t
+ t.package.distclean_custom
+ t.distclean
+ t.distclean_doc
+ t.distclean_test
+ args;
+
+ (* Remove generated file *)
+ List.iter
+ (fun fn ->
+ if Sys.file_exists fn then
+ begin
+ info (f_ "Remove '%s'") fn;
+ Sys.remove fn
+ end)
+ (BaseEnv.default_filename
+ ::
+ BaseLog.default_filename
+ ::
+ (List.rev_map BaseFileAB.to_filename t.package.files_ab))
+ in
+
+ clean, distclean
+
+
+ let version t _ =
+ print_endline t.oasis_version
+
+
+ let update_setup_ml, no_update_setup_ml_cli =
+ let b = ref true in
+ b,
+ ("-no-update-setup-ml",
+ Arg.Clear b,
+ s_ " Don't try to update setup.ml, even if _oasis has changed.")
+
+
+ let default_oasis_fn = "_oasis"
+
+
+ let update_setup_ml t =
+ let oasis_fn =
+ match t.oasis_fn with
+ | Some fn -> fn
+ | None -> default_oasis_fn
+ in
+ let oasis_exec =
+ match t.oasis_exec with
+ | Some fn -> fn
+ | None -> "oasis"
+ in
+ let ocaml =
+ Sys.executable_name
+ in
+ let setup_ml, args =
+ match Array.to_list Sys.argv with
+ | setup_ml :: args ->
+ setup_ml, args
+ | [] ->
+ failwith
+ (s_ "Expecting non-empty command line arguments.")
+ in
+ let ocaml, setup_ml =
+ if Sys.executable_name = Sys.argv.(0) then
+ (* We are not running in standard mode, probably the script
+ * is precompiled.
+ *)
+ "ocaml", "setup.ml"
+ else
+ ocaml, setup_ml
+ in
+ let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in
+ let do_update () =
+ let oasis_exec_version =
+ OASISExec.run_read_one_line
+ ~ctxt:!BaseContext.default
+ ~f_exit_code:
+ (function
+ | 0 ->
+ ()
+ | 1 ->
+ failwithf
+ (f_ "Executable '%s' is probably an old version \
+ of oasis (< 0.3.0), please update to version \
+ v%s.")
+ oasis_exec t.oasis_version
+ | 127 ->
+ failwithf
+ (f_ "Cannot find executable '%s', please install \
+ oasis v%s.")
+ oasis_exec t.oasis_version
+ | n ->
+ failwithf
+ (f_ "Command '%s version' exited with code %d.")
+ oasis_exec n)
+ oasis_exec ["version"]
+ in
+ if OASISVersion.comparator_apply
+ (OASISVersion.version_of_string oasis_exec_version)
+ (OASISVersion.VGreaterEqual
+ (OASISVersion.version_of_string t.oasis_version)) then
+ begin
+ (* We have a version >= for the executable oasis, proceed with
+ * update.
+ *)
+ (* TODO: delegate this check to 'oasis setup'. *)
+ if Sys.os_type = "Win32" then
+ failwithf
+ (f_ "It is not possible to update the running script \
+ setup.ml on Windows. Please update setup.ml by \
+ running '%s'.")
+ (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args))
+ else
+ begin
+ OASISExec.run
+ ~ctxt:!BaseContext.default
+ ~f_exit_code:
+ (function
+ | 0 ->
+ ()
+ | n ->
+ failwithf
+ (f_ "Unable to update setup.ml using '%s', \
+ please fix the problem and retry.")
+ oasis_exec)
+ oasis_exec ("setup" :: t.oasis_setup_args);
+ OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args)
+ end
+ end
+ else
+ failwithf
+ (f_ "The version of '%s' (v%s) doesn't match the version of \
+ oasis used to generate the %s file. Please install at \
+ least oasis v%s.")
+ oasis_exec oasis_exec_version setup_ml t.oasis_version
+ in
+
+ if !update_setup_ml then
+ begin
+ try
+ match t.oasis_digest with
+ | Some dgst ->
+ if Sys.file_exists oasis_fn &&
+ dgst <> Digest.file default_oasis_fn then
+ begin
+ do_update ();
+ true
+ end
+ else
+ false
+ | None ->
+ false
+ with e ->
+ error
+ (f_ "Error when updating setup.ml. If you want to avoid this error, \
+ you can bypass the update of %s by running '%s %s %s %s'")
+ setup_ml ocaml setup_ml no_update_setup_ml_cli
+ (String.concat " " args);
+ raise e
+ end
+ else
+ false
+
+
+ let setup t =
+ let catch_exn =
+ ref true
+ in
+ try
+ let act_ref =
+ ref (fun _ ->
+ failwithf
+ (f_ "No action defined, run '%s %s -help'")
+ Sys.executable_name
+ Sys.argv.(0))
+
+ in
+ let extra_args_ref =
+ ref []
+ in
+ let allow_empty_env_ref =
+ ref false
+ in
+ let arg_handle ?(allow_empty_env=false) act =
+ Arg.Tuple
+ [
+ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref);
+
+ Arg.Unit
+ (fun () ->
+ allow_empty_env_ref := allow_empty_env;
+ act_ref := act);
+ ]
+ in
+
+ Arg.parse
+ (Arg.align
+ ([
+ "-configure",
+ arg_handle ~allow_empty_env:true configure,
+ s_ "[options*] Configure the whole build process.";
+
+ "-build",
+ arg_handle build,
+ s_ "[options*] Build executables and libraries.";
+
+ "-doc",
+ arg_handle doc,
+ s_ "[options*] Build documents.";
+
+ "-test",
+ arg_handle test,
+ s_ "[options*] Run tests.";
+
+ "-all",
+ arg_handle ~allow_empty_env:true all,
+ s_ "[options*] Run configure, build, doc and test targets.";
+
+ "-install",
+ arg_handle install,
+ s_ "[options*] Install libraries, data, executables \
+ and documents.";
+
+ "-uninstall",
+ arg_handle uninstall,
+ s_ "[options*] Uninstall libraries, data, executables \
+ and documents.";
+
+ "-reinstall",
+ arg_handle reinstall,
+ s_ "[options*] Uninstall and install libraries, data, \
+ executables and documents.";
+
+ "-clean",
+ arg_handle ~allow_empty_env:true clean,
+ s_ "[options*] Clean files generated by a build.";
+
+ "-distclean",
+ arg_handle ~allow_empty_env:true distclean,
+ s_ "[options*] Clean files generated by a build and configure.";
+
+ "-version",
+ arg_handle ~allow_empty_env:true version,
+ s_ " Display version of OASIS used to generate this setup.ml.";
+
+ "-no-catch-exn",
+ Arg.Clear catch_exn,
+ s_ " Don't catch exception, useful for debugging.";
+ ]
+ @
+ (if t.setup_update then
+ [no_update_setup_ml_cli]
+ else
+ [])
+ @ (BaseContext.args ())))
+ (failwithf (f_ "Don't know what to do with '%s'"))
+ (s_ "Setup and run build process current package\n");
+
+ (* Build initial environment *)
+ load ~allow_empty:!allow_empty_env_ref ();
+
+ (** Initialize flags *)
+ List.iter
+ (function
+ | Flag (cs, {flag_description = hlp;
+ flag_default = choices}) ->
+ begin
+ let apply ?short_desc () =
+ var_ignore
+ (var_define
+ ~cli:CLIEnable
+ ?short_desc
+ (OASISUtils.varname_of_string cs.cs_name)
+ (fun () ->
+ string_of_bool
+ (var_choose
+ ~name:(Printf.sprintf
+ (f_ "default value of flag %s")
+ cs.cs_name)
+ ~printer:string_of_bool
+ choices)))
+ in
+ match hlp with
+ | Some hlp ->
+ apply ~short_desc:(fun () -> hlp) ()
+ | None ->
+ apply ()
+ end
+ | _ ->
+ ())
+ t.package.sections;
+
+ BaseStandardVar.init t.package;
+
+ BaseDynVar.init t.package;
+
+ if t.setup_update && update_setup_ml t then
+ ()
+ else
+ !act_ref t (Array.of_list (List.rev !extra_args_ref))
+
+ with e when !catch_exn ->
+ error "%s" (Printexc.to_string e);
+ exit 1
+
+
+end
+
+
+# 5432 "setup.ml"
+module InternalConfigurePlugin = struct
+(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *)
+
+
+ (** Configure using internal scheme
+ @author Sylvain Le Gall
+ *)
+
+
+ open BaseEnv
+ open OASISTypes
+ open OASISUtils
+ open OASISGettext
+ open BaseMessage
+
+
+ (** Configure build using provided series of check to be done
+ * and then output corresponding file.
+ *)
+ let configure pkg argv =
+ let var_ignore_eval var = let _s: string = var () in () in
+ let errors = ref SetString.empty in
+ let buff = Buffer.create 13 in
+
+ let add_errors fmt =
+ Printf.kbprintf
+ (fun b ->
+ errors := SetString.add (Buffer.contents b) !errors;
+ Buffer.clear b)
+ buff
+ fmt
+ in
+
+ let warn_exception e =
+ warning "%s" (Printexc.to_string e)
+ in
+
+ (* Check tools *)
+ let check_tools lst =
+ List.iter
+ (function
+ | ExternalTool tool ->
+ begin
+ try
+ var_ignore_eval (BaseCheck.prog tool)
+ with e ->
+ warn_exception e;
+ add_errors (f_ "Cannot find external tool '%s'") tool
+ end
+ | InternalExecutable nm1 ->
+ (* Check that matching tool is built *)
+ List.iter
+ (function
+ | Executable ({cs_name = nm2},
+ {bs_build = build},
+ _) when nm1 = nm2 ->
+ if not (var_choose build) then
+ add_errors
+ (f_ "Cannot find buildable internal executable \
+ '%s' when checking build depends")
+ nm1
+ | _ ->
+ ())
+ pkg.sections)
+ lst
+ in
+
+ let build_checks sct bs =
+ if var_choose bs.bs_build then
+ begin
+ if bs.bs_compiled_object = Native then
+ begin
+ try
+ var_ignore_eval BaseStandardVar.ocamlopt
+ with e ->
+ warn_exception e;
+ add_errors
+ (f_ "Section %s requires native compilation")
+ (OASISSection.string_of_section sct)
+ end;
+
+ (* Check tools *)
+ check_tools bs.bs_build_tools;
+
+ (* Check depends *)
+ List.iter
+ (function
+ | FindlibPackage (findlib_pkg, version_comparator) ->
+ begin
+ try
+ var_ignore_eval
+ (BaseCheck.package ?version_comparator findlib_pkg)
+ with e ->
+ warn_exception e;
+ match version_comparator with
+ | None ->
+ add_errors
+ (f_ "Cannot find findlib package %s")
+ findlib_pkg
+ | Some ver_cmp ->
+ add_errors
+ (f_ "Cannot find findlib package %s (%s)")
+ findlib_pkg
+ (OASISVersion.string_of_comparator ver_cmp)
+ end
+ | InternalLibrary nm1 ->
+ (* Check that matching library is built *)
+ List.iter
+ (function
+ | Library ({cs_name = nm2},
+ {bs_build = build},
+ _) when nm1 = nm2 ->
+ if not (var_choose build) then
+ add_errors
+ (f_ "Cannot find buildable internal library \
+ '%s' when checking build depends")
+ nm1
+ | _ ->
+ ())
+ pkg.sections)
+ bs.bs_build_depends
+ end
+ in
+
+ (* Parse command line *)
+ BaseArgExt.parse argv (BaseEnv.args ());
+
+ (* OCaml version *)
+ begin
+ match pkg.ocaml_version with
+ | Some ver_cmp ->
+ begin
+ try
+ var_ignore_eval
+ (BaseCheck.version
+ "ocaml"
+ ver_cmp
+ BaseStandardVar.ocaml_version)
+ with e ->
+ warn_exception e;
+ add_errors
+ (f_ "OCaml version %s doesn't match version constraint %s")
+ (BaseStandardVar.ocaml_version ())
+ (OASISVersion.string_of_comparator ver_cmp)
+ end
+ | None ->
+ ()
+ end;
+
+ (* Findlib version *)
+ begin
+ match pkg.findlib_version with
+ | Some ver_cmp ->
+ begin
+ try
+ var_ignore_eval
+ (BaseCheck.version
+ "findlib"
+ ver_cmp
+ BaseStandardVar.findlib_version)
+ with e ->
+ warn_exception e;
+ add_errors
+ (f_ "Findlib version %s doesn't match version constraint %s")
+ (BaseStandardVar.findlib_version ())
+ (OASISVersion.string_of_comparator ver_cmp)
+ end
+ | None ->
+ ()
+ end;
+ (* Make sure the findlib version is fine for the OCaml compiler. *)
+ begin
+ let ocaml_ge4 =
+ OASISVersion.version_compare
+ (OASISVersion.version_of_string (BaseStandardVar.ocaml_version()))
+ (OASISVersion.version_of_string "4.0.0") >= 0 in
+ if ocaml_ge4 then
+ let findlib_lt132 =
+ OASISVersion.version_compare
+ (OASISVersion.version_of_string (BaseStandardVar.findlib_version()))
+ (OASISVersion.version_of_string "1.3.2") < 0 in
+ if findlib_lt132 then
+ add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2"
+ end;
+
+ (* FlexDLL *)
+ if BaseStandardVar.os_type () = "Win32" ||
+ BaseStandardVar.os_type () = "Cygwin" then
+ begin
+ try
+ var_ignore_eval BaseStandardVar.flexlink
+ with e ->
+ warn_exception e;
+ add_errors (f_ "Cannot find 'flexlink'")
+ end;
+
+ (* Check build depends *)
+ List.iter
+ (function
+ | Executable (_, bs, _)
+ | Library (_, bs, _) as sct ->
+ build_checks sct bs
+ | Doc (_, doc) ->
+ if var_choose doc.doc_build then
+ check_tools doc.doc_build_tools
+ | Test (_, test) ->
+ if var_choose test.test_run then
+ check_tools test.test_tools
+ | _ ->
+ ())
+ pkg.sections;
+
+ (* Check if we need native dynlink (presence of libraries that compile to
+ * native)
+ *)
+ begin
+ let has_cmxa =
+ List.exists
+ (function
+ | Library (_, bs, _) ->
+ var_choose bs.bs_build &&
+ (bs.bs_compiled_object = Native ||
+ (bs.bs_compiled_object = Best &&
+ bool_of_string (BaseStandardVar.is_native ())))
+ | _ ->
+ false)
+ pkg.sections
+ in
+ if has_cmxa then
+ var_ignore_eval BaseStandardVar.native_dynlink
+ end;
+
+ (* Check errors *)
+ if SetString.empty != !errors then
+ begin
+ List.iter
+ (fun e -> error "%s" e)
+ (SetString.elements !errors);
+ failwithf
+ (fn_
+ "%d configuration error"
+ "%d configuration errors"
+ (SetString.cardinal !errors))
+ (SetString.cardinal !errors)
+ end
+
+
+end
+
+module InternalInstallPlugin = struct
+(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *)
+
+
+ (** Install using internal scheme
+ @author Sylvain Le Gall
+ *)
+
+
+ open BaseEnv
+ open BaseStandardVar
+ open BaseMessage
+ open OASISTypes
+ open OASISFindlib
+ open OASISGettext
+ open OASISUtils
+
+
+ let exec_hook =
+ ref (fun (cs, bs, exec) -> cs, bs, exec)
+
+
+ let lib_hook =
+ ref (fun (cs, bs, lib) -> cs, bs, lib, [])
+
+
+ let obj_hook =
+ ref (fun (cs, bs, obj) -> cs, bs, obj, [])
+
+
+ let doc_hook =
+ ref (fun (cs, doc) -> cs, doc)
+
+
+ let install_file_ev =
+ "install-file"
+
+
+ let install_dir_ev =
+ "install-dir"
+
+
+ let install_findlib_ev =
+ "install-findlib"
+
+
+ let win32_max_command_line_length = 8000
+
+
+ let split_install_command ocamlfind findlib_name meta files =
+ if Sys.os_type = "Win32" then
+ (* Arguments for the first command: *)
+ let first_args = ["install"; findlib_name; meta] in
+ (* Arguments for remaining commands: *)
+ let other_args = ["install"; findlib_name; "-add"] in
+ (* Extract as much files as possible from [files], [len] is
+ the current command line length: *)
+ let rec get_files len acc files =
+ match files with
+ | [] ->
+ (List.rev acc, [])
+ | file :: rest ->
+ let len = len + 1 + String.length file in
+ if len > win32_max_command_line_length then
+ (List.rev acc, files)
+ else
+ get_files len (file :: acc) rest
+ in
+ (* Split the command into several commands. *)
+ let rec split args files =
+ match files with
+ | [] ->
+ []
+ | _ ->
+ (* Length of "ocamlfind install <lib> [META|-add]" *)
+ let len =
+ List.fold_left
+ (fun len arg ->
+ len + 1 (* for the space *) + String.length arg)
+ (String.length ocamlfind)
+ args
+ in
+ match get_files len [] files with
+ | ([], _) ->
+ failwith (s_ "Command line too long.")
+ | (firsts, others) ->
+ let cmd = args @ firsts in
+ (* Use -add for remaining commands: *)
+ let () =
+ let findlib_ge_132 =
+ OASISVersion.comparator_apply
+ (OASISVersion.version_of_string
+ (BaseStandardVar.findlib_version ()))
+ (OASISVersion.VGreaterEqual
+ (OASISVersion.version_of_string "1.3.2"))
+ in
+ if not findlib_ge_132 then
+ failwithf
+ (f_ "Installing the library %s require to use the \
+ flag '-add' of ocamlfind because the command \
+ line is too long. This flag is only available \
+ for findlib 1.3.2. Please upgrade findlib from \
+ %s to 1.3.2")
+ findlib_name (BaseStandardVar.findlib_version ())
+ in
+ let cmds = split other_args others in
+ cmd :: cmds
+ in
+ (* The first command does not use -add: *)
+ split first_args files
+ else
+ ["install" :: findlib_name :: meta :: files]
+
+
+ let install pkg argv =
+
+ let in_destdir =
+ try
+ let destdir =
+ destdir ()
+ in
+ (* Practically speaking destdir is prepended
+ * at the beginning of the target filename
+ *)
+ fun fn -> destdir^fn
+ with PropList.Not_set _ ->
+ fun fn -> fn
+ in
+
+ let install_file ?tgt_fn src_file envdir =
+ let tgt_dir =
+ in_destdir (envdir ())
+ in
+ let tgt_file =
+ Filename.concat
+ tgt_dir
+ (match tgt_fn with
+ | Some fn ->
+ fn
+ | None ->
+ Filename.basename src_file)
+ in
+ (* Create target directory if needed *)
+ OASISFileUtil.mkdir_parent
+ ~ctxt:!BaseContext.default
+ (fun dn ->
+ info (f_ "Creating directory '%s'") dn;
+ BaseLog.register install_dir_ev dn)
+ tgt_dir;
+
+ (* Really install files *)
+ info (f_ "Copying file '%s' to '%s'") src_file tgt_file;
+ OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file;
+ BaseLog.register install_file_ev tgt_file
+ in
+
+ (* Install data into defined directory *)
+ let install_data srcdir lst tgtdir =
+ let tgtdir =
+ OASISHostPath.of_unix (var_expand tgtdir)
+ in
+ List.iter
+ (fun (src, tgt_opt) ->
+ let real_srcs =
+ OASISFileUtil.glob
+ ~ctxt:!BaseContext.default
+ (Filename.concat srcdir src)
+ in
+ if real_srcs = [] then
+ failwithf
+ (f_ "Wildcard '%s' doesn't match any files")
+ src;
+ List.iter
+ (fun fn ->
+ install_file
+ fn
+ (fun () ->
+ match tgt_opt with
+ | Some s ->
+ OASISHostPath.of_unix (var_expand s)
+ | None ->
+ tgtdir))
+ real_srcs)
+ lst
+ in
+
+ let make_fnames modul sufx =
+ List.fold_right
+ begin fun sufx accu ->
+ (OASISString.capitalize_ascii modul ^ sufx) ::
+ (OASISString.uncapitalize_ascii modul ^ sufx) ::
+ accu
+ end
+ sufx
+ []
+ in
+
+ (** Install all libraries *)
+ let install_libs pkg =
+
+ let files_of_library (f_data, acc) data_lib =
+ let cs, bs, lib, lib_extra =
+ !lib_hook data_lib
+ in
+ if var_choose bs.bs_install &&
+ BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then
+ begin
+ let acc =
+ (* Start with acc + lib_extra *)
+ List.rev_append lib_extra acc
+ in
+ let acc =
+ (* Add uncompiled header from the source tree *)
+ let path =
+ OASISHostPath.of_unix bs.bs_path
+ in
+ List.fold_left
+ begin fun acc modul ->
+ begin
+ try
+ [List.find
+ OASISFileUtil.file_exists_case
+ (List.map
+ (Filename.concat path)
+ (make_fnames modul [".mli"; ".ml"]))]
+ with Not_found ->
+ warning
+ (f_ "Cannot find source header for module %s \
+ in library %s")
+ modul cs.cs_name;
+ []
+ end
+ @
+ List.filter
+ OASISFileUtil.file_exists_case
+ (List.map
+ (Filename.concat path)
+ (make_fnames modul [".annot";".cmti";".cmt"]))
+ @ acc
+ end
+ acc
+ lib.lib_modules
+ in
+
+ let acc =
+ (* Get generated files *)
+ BaseBuilt.fold
+ BaseBuilt.BLib
+ cs.cs_name
+ (fun acc fn -> fn :: acc)
+ acc
+ in
+
+ let f_data () =
+ (* Install data associated with the library *)
+ install_data
+ bs.bs_path
+ bs.bs_data_files
+ (Filename.concat
+ (datarootdir ())
+ pkg.name);
+ f_data ()
+ in
+
+ (f_data, acc)
+ end
+ else
+ begin
+ (f_data, acc)
+ end
+ and files_of_object (f_data, acc) data_obj =
+ let cs, bs, obj, obj_extra =
+ !obj_hook data_obj
+ in
+ if var_choose bs.bs_install &&
+ BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then
+ begin
+ let acc =
+ (* Start with acc + obj_extra *)
+ List.rev_append obj_extra acc
+ in
+ let acc =
+ (* Add uncompiled header from the source tree *)
+ let path =
+ OASISHostPath.of_unix bs.bs_path
+ in
+ List.fold_left
+ begin fun acc modul ->
+ begin
+ try
+ [List.find
+ OASISFileUtil.file_exists_case
+ (List.map
+ (Filename.concat path)
+ (make_fnames modul [".mli"; ".ml"]))]
+ with Not_found ->
+ warning
+ (f_ "Cannot find source header for module %s \
+ in object %s")
+ modul cs.cs_name;
+ []
+ end
+ @
+ List.filter
+ OASISFileUtil.file_exists_case
+ (List.map
+ (Filename.concat path)
+ (make_fnames modul [".annot";".cmti";".cmt"]))
+ @ acc
+ end
+ acc
+ obj.obj_modules
+ in
+
+ let acc =
+ (* Get generated files *)
+ BaseBuilt.fold
+ BaseBuilt.BObj
+ cs.cs_name
+ (fun acc fn -> fn :: acc)
+ acc
+ in
+
+ let f_data () =
+ (* Install data associated with the object *)
+ install_data
+ bs.bs_path
+ bs.bs_data_files
+ (Filename.concat
+ (datarootdir ())
+ pkg.name);
+ f_data ()
+ in
+
+ (f_data, acc)
+ end
+ else
+ begin
+ (f_data, acc)
+ end
+
+ in
+
+ (* Install one group of library *)
+ let install_group_lib grp =
+ (* Iterate through all group nodes *)
+ let rec install_group_lib_aux data_and_files grp =
+ let data_and_files, children =
+ match grp with
+ | Container (_, children) ->
+ data_and_files, children
+ | Package (_, cs, bs, `Library lib, children) ->
+ files_of_library data_and_files (cs, bs, lib), children
+ | Package (_, cs, bs, `Object obj, children) ->
+ files_of_object data_and_files (cs, bs, obj), children
+ in
+ List.fold_left
+ install_group_lib_aux
+ data_and_files
+ children
+ in
+
+ (* Findlib name of the root library *)
+ let findlib_name =
+ findlib_of_group grp
+ in
+
+ (* Determine root library *)
+ let root_lib =
+ root_of_group grp
+ in
+
+ (* All files to install for this library *)
+ let f_data, files =
+ install_group_lib_aux (ignore, []) grp
+ in
+
+ (* Really install, if there is something to install *)
+ if files = [] then
+ begin
+ warning
+ (f_ "Nothing to install for findlib library '%s'")
+ findlib_name
+ end
+ else
+ begin
+ let meta =
+ (* Search META file *)
+ let _, bs, _ =
+ root_lib
+ in
+ let res =
+ Filename.concat bs.bs_path "META"
+ in
+ if not (OASISFileUtil.file_exists_case res) then
+ failwithf
+ (f_ "Cannot find file '%s' for findlib library %s")
+ res
+ findlib_name;
+ res
+ in
+ let files =
+ (* Make filename shorter to avoid hitting command max line length
+ * too early, esp. on Windows.
+ *)
+ let remove_prefix p n =
+ let plen = String.length p in
+ let nlen = String.length n in
+ if plen <= nlen && String.sub n 0 plen = p then
+ begin
+ let fn_sep =
+ if Sys.os_type = "Win32" then
+ '\\'
+ else
+ '/'
+ in
+ let cutpoint = plen +
+ (if plen < nlen && n.[plen] = fn_sep then
+ 1
+ else
+ 0)
+ in
+ String.sub n cutpoint (nlen - cutpoint)
+ end
+ else
+ n
+ in
+ List.map (remove_prefix (Sys.getcwd ())) files
+ in
+ info
+ (f_ "Installing findlib library '%s'")
+ findlib_name;
+ let ocamlfind = ocamlfind () in
+ let commands =
+ split_install_command
+ ocamlfind
+ findlib_name
+ meta
+ files
+ in
+ List.iter
+ (OASISExec.run ~ctxt:!BaseContext.default ocamlfind)
+ commands;
+ BaseLog.register install_findlib_ev findlib_name
+ end;
+
+ (* Install data files *)
+ f_data ();
+
+ in
+
+ let group_libs, _, _ =
+ findlib_mapping pkg
+ in
+
+ (* We install libraries in groups *)
+ List.iter install_group_lib group_libs
+ in
+
+ let install_execs pkg =
+ let install_exec data_exec =
+ let cs, bs, exec =
+ !exec_hook data_exec
+ in
+ if var_choose bs.bs_install &&
+ BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then
+ begin
+ let exec_libdir () =
+ Filename.concat
+ (libdir ())
+ pkg.name
+ in
+ BaseBuilt.fold
+ BaseBuilt.BExec
+ cs.cs_name
+ (fun () fn ->
+ install_file
+ ~tgt_fn:(cs.cs_name ^ ext_program ())
+ fn
+ bindir)
+ ();
+ BaseBuilt.fold
+ BaseBuilt.BExecLib
+ cs.cs_name
+ (fun () fn ->
+ install_file
+ fn
+ exec_libdir)
+ ();
+ install_data
+ bs.bs_path
+ bs.bs_data_files
+ (Filename.concat
+ (datarootdir ())
+ pkg.name)
+ end
+ in
+ List.iter
+ (function
+ | Executable (cs, bs, exec)->
+ install_exec (cs, bs, exec)
+ | _ ->
+ ())
+ pkg.sections
+ in
+
+ let install_docs pkg =
+ let install_doc data =
+ let cs, doc =
+ !doc_hook data
+ in
+ if var_choose doc.doc_install &&
+ BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then
+ begin
+ let tgt_dir =
+ OASISHostPath.of_unix (var_expand doc.doc_install_dir)
+ in
+ BaseBuilt.fold
+ BaseBuilt.BDoc
+ cs.cs_name
+ (fun () fn ->
+ install_file
+ fn
+ (fun () -> tgt_dir))
+ ();
+ install_data
+ Filename.current_dir_name
+ doc.doc_data_files
+ doc.doc_install_dir
+ end
+ in
+ List.iter
+ (function
+ | Doc (cs, doc) ->
+ install_doc (cs, doc)
+ | _ ->
+ ())
+ pkg.sections
+ in
+
+ install_libs pkg;
+ install_execs pkg;
+ install_docs pkg
+
+
+ (* Uninstall already installed data *)
+ let uninstall _ argv =
+ List.iter
+ (fun (ev, data) ->
+ if ev = install_file_ev then
+ begin
+ if OASISFileUtil.file_exists_case data then
+ begin
+ info
+ (f_ "Removing file '%s'")
+ data;
+ Sys.remove data
+ end
+ else
+ begin
+ warning
+ (f_ "File '%s' doesn't exist anymore")
+ data
+ end
+ end
+ else if ev = install_dir_ev then
+ begin
+ if Sys.file_exists data && Sys.is_directory data then
+ begin
+ if Sys.readdir data = [||] then
+ begin
+ info
+ (f_ "Removing directory '%s'")
+ data;
+ OASISFileUtil.rmdir ~ctxt:!BaseContext.default data
+ end
+ else
+ begin
+ warning
+ (f_ "Directory '%s' is not empty (%s)")
+ data
+ (String.concat
+ ", "
+ (Array.to_list
+ (Sys.readdir data)))
+ end
+ end
+ else
+ begin
+ warning
+ (f_ "Directory '%s' doesn't exist anymore")
+ data
+ end
+ end
+ else if ev = install_findlib_ev then
+ begin
+ info (f_ "Removing findlib library '%s'") data;
+ OASISExec.run ~ctxt:!BaseContext.default
+ (ocamlfind ()) ["remove"; data]
+ end
+ else
+ failwithf (f_ "Unknown log event '%s'") ev;
+ BaseLog.unregister ev data)
+ (* We process event in reverse order *)
+ (List.rev
+ (BaseLog.filter
+ [install_file_ev;
+ install_dir_ev;
+ install_findlib_ev]))
+
+
+end
+
+
+# 6296 "setup.ml"
+module OCamlbuildCommon = struct
+(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *)
+
+
+ (** Functions common to OCamlbuild build and doc plugin
+ *)
+
+
+ open OASISGettext
+ open BaseEnv
+ open BaseStandardVar
+ open OASISTypes
+
+
+
+
+ type extra_args = string list
+
+
+ let ocamlbuild_clean_ev = "ocamlbuild-clean"
+
+
+ let ocamlbuildflags =
+ var_define
+ ~short_desc:(fun () -> "OCamlbuild additional flags")
+ "ocamlbuildflags"
+ (fun () -> "")
+
+
+ (** Fix special arguments depending on environment *)
+ let fix_args args extra_argv =
+ List.flatten
+ [
+ if (os_type ()) = "Win32" then
+ [
+ "-classic-display";
+ "-no-log";
+ "-no-links";
+ "-install-lib-dir";
+ (Filename.concat (standard_library ()) "ocamlbuild")
+ ]
+ else
+ [];
+
+ if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then
+ [
+ "-byte-plugin"
+ ]
+ else
+ [];
+ args;
+
+ if bool_of_string (debug ()) then
+ ["-tag"; "debug"]
+ else
+ [];
+
+ if bool_of_string (tests ()) then
+ ["-tag"; "tests"]
+ else
+ [];
+
+ if bool_of_string (profile ()) then
+ ["-tag"; "profile"]
+ else
+ [];
+
+ OASISString.nsplit (ocamlbuildflags ()) ' ';
+
+ Array.to_list extra_argv;
+ ]
+
+
+ (** Run 'ocamlbuild -clean' if not already done *)
+ let run_clean extra_argv =
+ let extra_cli =
+ String.concat " " (Array.to_list extra_argv)
+ in
+ (* Run if never called with these args *)
+ if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then
+ begin
+ OASISExec.run ~ctxt:!BaseContext.default
+ (ocamlbuild ()) (fix_args ["-clean"] extra_argv);
+ BaseLog.register ocamlbuild_clean_ev extra_cli;
+ at_exit
+ (fun () ->
+ try
+ BaseLog.unregister ocamlbuild_clean_ev extra_cli
+ with _ ->
+ ())
+ end
+
+
+ (** Run ocamlbuild, unregister all clean events *)
+ let run_ocamlbuild args extra_argv =
+ (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html
+ *)
+ OASISExec.run ~ctxt:!BaseContext.default
+ (ocamlbuild ()) (fix_args args extra_argv);
+ (* Remove any clean event, we must run it again *)
+ List.iter
+ (fun (e, d) -> BaseLog.unregister e d)
+ (BaseLog.filter [ocamlbuild_clean_ev])
+
+
+ (** Determine real build directory *)
+ let build_dir extra_argv =
+ let rec search_args dir =
+ function
+ | "-build-dir" :: dir :: tl ->
+ search_args dir tl
+ | _ :: tl ->
+ search_args dir tl
+ | [] ->
+ dir
+ in
+ search_args "_build" (fix_args [] extra_argv)
+
+
+end
+
+module OCamlbuildPlugin = struct
+(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *)
+
+
+ (** Build using ocamlbuild
+ @author Sylvain Le Gall
+ *)
+
+
+ open OASISTypes
+ open OASISGettext
+ open OASISUtils
+ open OASISString
+ open BaseEnv
+ open OCamlbuildCommon
+ open BaseStandardVar
+ open BaseMessage
+
+
+
+
+
+ let cond_targets_hook =
+ ref (fun lst -> lst)
+
+
+ let build extra_args pkg argv =
+ (* Return the filename in build directory *)
+ let in_build_dir fn =
+ Filename.concat
+ (build_dir argv)
+ fn
+ in
+
+ (* Return the unix filename in host build directory *)
+ let in_build_dir_of_unix fn =
+ in_build_dir (OASISHostPath.of_unix fn)
+ in
+
+ let cond_targets =
+ List.fold_left
+ (fun acc ->
+ function
+ | Library (cs, bs, lib) when var_choose bs.bs_build ->
+ begin
+ let evs, unix_files =
+ BaseBuilt.of_library
+ in_build_dir_of_unix
+ (cs, bs, lib)
+ in
+
+ let tgts =
+ List.flatten
+ (List.filter
+ (fun l -> l <> [])
+ (List.map
+ (List.filter
+ (fun fn ->
+ ends_with ~what:".cma" fn
+ || ends_with ~what:".cmxs" fn
+ || ends_with ~what:".cmxa" fn
+ || ends_with ~what:(ext_lib ()) fn
+ || ends_with ~what:(ext_dll ()) fn))
+ unix_files))
+ in
+
+ match tgts with
+ | _ :: _ ->
+ (evs, tgts) :: acc
+ | [] ->
+ failwithf
+ (f_ "No possible ocamlbuild targets for library %s")
+ cs.cs_name
+ end
+
+ | Object (cs, bs, obj) when var_choose bs.bs_build ->
+ begin
+ let evs, unix_files =
+ BaseBuilt.of_object
+ in_build_dir_of_unix
+ (cs, bs, obj)
+ in
+
+ let tgts =
+ List.flatten
+ (List.filter
+ (fun l -> l <> [])
+ (List.map
+ (List.filter
+ (fun fn ->
+ ends_with ".cmo" fn
+ || ends_with ".cmx" fn))
+ unix_files))
+ in
+
+ match tgts with
+ | _ :: _ ->
+ (evs, tgts) :: acc
+ | [] ->
+ failwithf
+ (f_ "No possible ocamlbuild targets for object %s")
+ cs.cs_name
+ end
+
+ | Executable (cs, bs, exec) when var_choose bs.bs_build ->
+ begin
+ let evs, unix_exec_is, unix_dll_opt =
+ BaseBuilt.of_executable
+ in_build_dir_of_unix
+ (cs, bs, exec)
+ in
+
+ let target ext =
+ let unix_tgt =
+ (OASISUnixPath.concat
+ bs.bs_path
+ (OASISUnixPath.chop_extension
+ exec.exec_main_is))^ext
+ in
+ let evs =
+ (* Fix evs, we want to use the unix_tgt, without copying *)
+ List.map
+ (function
+ | BaseBuilt.BExec, nm, lst when nm = cs.cs_name ->
+ BaseBuilt.BExec, nm,
+ [[in_build_dir_of_unix unix_tgt]]
+ | ev ->
+ ev)
+ evs
+ in
+ evs, [unix_tgt]
+ in
+
+ (* Add executable *)
+ let acc =
+ match bs.bs_compiled_object with
+ | Native ->
+ (target ".native") :: acc
+ | Best when bool_of_string (is_native ()) ->
+ (target ".native") :: acc
+ | Byte
+ | Best ->
+ (target ".byte") :: acc
+ in
+ acc
+ end
+
+ | Library _ | Object _ | Executable _ | Test _
+ | SrcRepo _ | Flag _ | Doc _ ->
+ acc)
+ []
+ (* Keep the pkg.sections ordered *)
+ (List.rev pkg.sections);
+ in
+
+ (* Check and register built files *)
+ let check_and_register (bt, bnm, lst) =
+ List.iter
+ (fun fns ->
+ if not (List.exists OASISFileUtil.file_exists_case fns) then
+ failwithf
+ (fn_
+ "Expected built file %s doesn't exist."
+ "None of expected built files %s exists."
+ (List.length fns))
+ (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns)))
+ lst;
+ (BaseBuilt.register bt bnm lst)
+ in
+
+ (* Run the hook *)
+ let cond_targets = !cond_targets_hook cond_targets in
+
+ (* Run a list of target... *)
+ run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv;
+ (* ... and register events *)
+ List.iter check_and_register (List.flatten (List.map fst cond_targets))
+
+
+ let clean pkg extra_args =
+ run_clean extra_args;
+ List.iter
+ (function
+ | Library (cs, _, _) ->
+ BaseBuilt.unregister BaseBuilt.BLib cs.cs_name
+ | Executable (cs, _, _) ->
+ BaseBuilt.unregister BaseBuilt.BExec cs.cs_name;
+ BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name
+ | _ ->
+ ())
+ pkg.sections
+
+
+end
+
+module OCamlbuildDocPlugin = struct
+(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *)
+
+
+ (* Create documentation using ocamlbuild .odocl files
+ @author Sylvain Le Gall
+ *)
+
+
+ open OASISTypes
+ open OASISGettext
+ open OASISMessage
+ open OCamlbuildCommon
+ open BaseStandardVar
+
+
+
+
+ type run_t =
+ {
+ extra_args: string list;
+ run_path: unix_filename;
+ }
+
+
+ let doc_build run pkg (cs, doc) argv =
+ let index_html =
+ OASISUnixPath.make
+ [
+ run.run_path;
+ cs.cs_name^".docdir";
+ "index.html";
+ ]
+ in
+ let tgt_dir =
+ OASISHostPath.make
+ [
+ build_dir argv;
+ OASISHostPath.of_unix run.run_path;
+ cs.cs_name^".docdir";
+ ]
+ in
+ run_ocamlbuild (index_html :: run.extra_args) argv;
+ List.iter
+ (fun glb ->
+ BaseBuilt.register
+ BaseBuilt.BDoc
+ cs.cs_name
+ [OASISFileUtil.glob ~ctxt:!BaseContext.default
+ (Filename.concat tgt_dir glb)])
+ ["*.html"; "*.css"]
+
+
+ let doc_clean run pkg (cs, doc) argv =
+ run_clean argv;
+ BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name
+
+
+end
+
+
+# 6674 "setup.ml"
+open OASISTypes;;
+
+let setup_t =
+ {
+ BaseSetup.configure = InternalConfigurePlugin.configure;
+ build = OCamlbuildPlugin.build ["-use-ocamlfind"];
+ test = [];
+ doc =
+ [
+ ("keystone",
+ OCamlbuildDocPlugin.doc_build
+ {
+ OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"];
+ run_path = "."
+ })
+ ];
+ install = InternalInstallPlugin.install;
+ uninstall = InternalInstallPlugin.uninstall;
+ clean = [OCamlbuildPlugin.clean];
+ clean_test = [];
+ clean_doc =
+ [
+ ("keystone",
+ OCamlbuildDocPlugin.doc_clean
+ {
+ OCamlbuildDocPlugin.extra_args = ["-use-ocamlfind"];
+ run_path = "."
+ })
+ ];
+ distclean = [];
+ distclean_test = [];
+ distclean_doc = [];
+ package =
+ {
+ oasis_version = "0.4";
+ ocaml_version = Some (OASISVersion.VGreaterEqual "4.01");
+ findlib_version = None;
+ alpha_features = [];
+ beta_features = [];
+ name = "keystone";
+ version = "0.1";
+ license =
+ OASISLicense.DEP5License
+ (OASISLicense.DEP5Unit
+ {
+ OASISLicense.license = "LGPL";
+ excption = Some "OCaml linking";
+ version = OASISLicense.Version "2.1"
+ });
+ license_file = None;
+ copyrights = [];
+ maintainers = [];
+ authors = ["Aziem Chawdhary"];
+ homepage = None;
+ synopsis = "Ctypes bindings to Keystone assembler for OCaml";
+ description = None;
+ categories = [];
+ conf_type = (`Configure, "internal", Some "0.4");
+ conf_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)]
+ };
+ build_type = (`Build, "ocamlbuild", Some "0.4");
+ build_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)]
+ };
+ install_type = (`Install, "internal", Some "0.4");
+ install_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)]
+ };
+ uninstall_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)]
+ };
+ clean_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)]
+ };
+ distclean_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)]
+ };
+ files_ab = [];
+ sections =
+ [
+ Library
+ ({
+ cs_name = "keystone";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = []
+ },
+ {
+ bs_build = [(OASISExpr.EBool true, true)];
+ bs_install = [(OASISExpr.EBool true, true)];
+ bs_path = ".";
+ bs_compiled_object = Native;
+ bs_build_depends =
+ [
+ FindlibPackage ("ctypes", None);
+ FindlibPackage ("uchar", None);
+ FindlibPackage ("ctypes.stubs", None);
+ FindlibPackage ("ctypes.foreign", None);
+ FindlibPackage ("result", None)
+ ];
+ bs_build_tools = [ExternalTool "ocamlbuild"];
+ bs_c_sources = ["ffi_generated_stubs.c"];
+ bs_data_files = [];
+ bs_ccopt =
+ [
+ (OASISExpr.EBool true,
+ ["-I"; "${pkg_ctypes_stubs}"])
+ ];
+ bs_cclib = [(OASISExpr.EBool true, ["-lkeystone"])];
+ bs_dlllib = [(OASISExpr.EBool true, [])];
+ bs_dllpath = [(OASISExpr.EBool true, [])];
+ bs_byteopt = [(OASISExpr.EBool true, [])];
+ bs_nativeopt = [(OASISExpr.EBool true, [])]
+ },
+ {
+ lib_modules =
+ [
+ "Keystone";
+ "Ffi_generated";
+ "Ffi_types";
+ "Ffi_bindings";
+ "Ffi_generated_types"
+ ];
+ lib_pack = false;
+ lib_internal_modules = [];
+ lib_findlib_parent = None;
+ lib_findlib_name = Some "keystone";
+ lib_findlib_containers = []
+ });
+ Doc
+ ({
+ cs_name = "keystone";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = []
+ },
+ {
+ doc_type = (`Doc, "ocamlbuild", Some "0.4");
+ doc_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)]
+ };
+ doc_build =
+ [
+ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false);
+ (OASISExpr.EFlag "docs", true)
+ ];
+ doc_install = [(OASISExpr.EBool true, true)];
+ doc_install_dir = "$docdir";
+ doc_title = "API reference for Keystone";
+ doc_authors = [];
+ doc_abstract = None;
+ doc_format = OtherDoc;
+ doc_data_files = [];
+ doc_build_tools =
+ [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]
+ });
+ Executable
+ ({
+ cs_name = "ffi_types_stubgen";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = []
+ },
+ {
+ bs_build = [(OASISExpr.EBool true, true)];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = ".";
+ bs_compiled_object = Native;
+ bs_build_depends =
+ [FindlibPackage ("ctypes.stubs", None)];
+ bs_build_tools = [ExternalTool "ocamlbuild"];
+ bs_c_sources = [];
+ bs_data_files = [];
+ bs_ccopt = [(OASISExpr.EBool true, [])];
+ bs_cclib = [(OASISExpr.EBool true, [])];
+ bs_dlllib = [(OASISExpr.EBool true, [])];
+ bs_dllpath = [(OASISExpr.EBool true, [])];
+ bs_byteopt = [(OASISExpr.EBool true, [])];
+ bs_nativeopt = [(OASISExpr.EBool true, [])]
+ },
+ {
+ exec_custom = false;
+ exec_main_is = "ffi_types_stubgen.ml"
+ });
+ Executable
+ ({
+ cs_name = "ffi_stubgen";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = []
+ },
+ {
+ bs_build = [(OASISExpr.EBool true, true)];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = ".";
+ bs_compiled_object = Native;
+ bs_build_depends =
+ [
+ FindlibPackage ("ctypes.stubs", None);
+ FindlibPackage ("ctypes.foreign", None)
+ ];
+ bs_build_tools = [ExternalTool "ocamlbuild"];
+ bs_c_sources = [];
+ bs_data_files = [];
+ bs_ccopt = [(OASISExpr.EBool true, [])];
+ bs_cclib = [(OASISExpr.EBool true, [])];
+ bs_dlllib = [(OASISExpr.EBool true, [])];
+ bs_dllpath = [(OASISExpr.EBool true, [])];
+ bs_byteopt = [(OASISExpr.EBool true, [])];
+ bs_nativeopt = [(OASISExpr.EBool true, [])]
+ },
+ {exec_custom = false; exec_main_is = "ffi_stubgen.ml"});
+ Executable
+ ({
+ cs_name = "test_bindings";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = []
+ },
+ {
+ bs_build = [(OASISExpr.EBool true, true)];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = ".";
+ bs_compiled_object = Native;
+ bs_build_depends = [InternalLibrary "keystone"];
+ bs_build_tools = [ExternalTool "ocamlbuild"];
+ bs_c_sources = [];
+ bs_data_files = [];
+ bs_ccopt = [(OASISExpr.EBool true, [])];
+ bs_cclib = [(OASISExpr.EBool true, ["-lkeystone"])];
+ bs_dlllib = [(OASISExpr.EBool true, [])];
+ bs_dllpath = [(OASISExpr.EBool true, [])];
+ bs_byteopt = [(OASISExpr.EBool true, [])];
+ bs_nativeopt = [(OASISExpr.EBool true, [])]
+ },
+ {exec_custom = false; exec_main_is = "test_bindings.ml"})
+ ];
+ plugins =
+ [(`Extra, "DevFiles", Some "0.4"); (`Extra, "META", Some "0.4")];
+ disable_oasis_section = [];
+ schema_data = PropList.Data.create ();
+ plugin_data = []
+ };
+ oasis_fn = Some "_oasis";
+ oasis_version = "0.4.6";
+ oasis_digest = Some "\0174\176\255\171N\142\235\136\215R8\140\185^\250";
+ oasis_exec = None;
+ oasis_setup_args = [];
+ setup_update = false
+ };;
+
+let setup () = BaseSetup.setup setup_t;;
+
+# 6939 "setup.ml"
+(* OASIS_STOP *)
+let () = setup ();;
diff --git a/bindings/ocaml/test_bindings.ml b/bindings/ocaml/test_bindings.ml
new file mode 100644
index 0000000000000000000000000000000000000000..09d3f2b4057a2d6896140ed9cb7ff2a26d06d23e
--- /dev/null
+++ b/bindings/ocaml/test_bindings.ml
@@ -0,0 +1,55 @@
+open Keystone
+
+module T = Keystone.Types
+
+let test_ks arch mode ?(syntax=T.KS_OPT_SYNTAX_INTEL) ?(endian=T.KS_MODE_LITTLE_ENDIAN) asm =
+ match (ks_open arch ~endian:endian mode) with
+ | Result.Ok engine ->
+ begin
+ ignore(ks_option engine T.KS_OPT_SYNTAX syntax);
+ match (ks_asm engine asm 0) with
+ | Result.Ok(result) ->
+ Printf.printf "%s = %s\nAssembled: %i bytes, %i statements\n \n"
+ asm
+ (asm_array_to_string result.encoding)
+ result.encoding_size
+ result.stat_count;
+ ignore(ks_close engine)
+
+ | Result.Error s -> Printf.printf "ERROR: failed on ks_asm with: %s\n" s
+ end
+
+ | Result.Error e -> Printf.printf "ERROR: failed on ks_open: %s\n" e
+
+
+let _ =
+ test_ks T.KS_ARCH_X86 T.KS_MODE_16 "add eax, ecx";
+ test_ks T.KS_ARCH_X86 T.KS_MODE_32 "add eax, ecx";
+ test_ks T.KS_ARCH_X86 T.KS_MODE_64 "add rax, rcx";
+ test_ks T.KS_ARCH_X86 T.KS_MODE_32 ~syntax:T.KS_OPT_SYNTAX_ATT "add %ecx, %eax";
+ test_ks T.KS_ARCH_X86 T.KS_MODE_64 ~syntax:T.KS_OPT_SYNTAX_ATT "add %rcx, %rax";
+
+ test_ks T.KS_ARCH_ARM T.KS_MODE_ARM "sub r1, r2, r5";
+ test_ks T.KS_ARCH_ARM T.KS_MODE_ARM "sub r1, r2, r5";
+ test_ks T.KS_ARCH_ARM T.KS_MODE_ARM ~endian:T.KS_MODE_BIG_ENDIAN "sub r1, r2, r5";
+ test_ks T.KS_ARCH_ARM T.KS_MODE_THUMB "movs r4, #0xf0";
+ test_ks T.KS_ARCH_ARM T.KS_MODE_THUMB ~endian:T.KS_MODE_BIG_ENDIAN "movs r4, #0xf0";
+
+ test_ks T.KS_ARCH_ARM64 T.KS_MODE_LITTLE_ENDIAN "ldr w1, [sp, #0x8]";
+
+ test_ks T.KS_ARCH_HEXAGON T.KS_MODE_BIG_ENDIAN "v23.w=vavg(v11.w,v2.w):rnd";
+
+ test_ks T.KS_ARCH_MIPS T.KS_MODE_MIPS32 "and $9, $6, $7";
+ test_ks T.KS_ARCH_MIPS T.KS_MODE_MIPS32 ~endian:T.KS_MODE_BIG_ENDIAN "and $9, $6, $7";
+
+ test_ks T.KS_ARCH_MIPS T.KS_MODE_MIPS64 "and $9, $6, $7";
+ test_ks T.KS_ARCH_MIPS T.KS_MODE_MIPS64 ~endian:T.KS_MODE_BIG_ENDIAN "and $9, $6, $7";
+
+ test_ks T.KS_ARCH_PPC T.KS_MODE_PPC32 ~endian:T.KS_MODE_BIG_ENDIAN "add 1,2,3";
+ test_ks T.KS_ARCH_PPC T.KS_MODE_PPC64 "add 1,2,3";
+ test_ks T.KS_ARCH_PPC T.KS_MODE_PPC64 ~endian:T.KS_MODE_BIG_ENDIAN "add 1,2,3";
+
+ test_ks T.KS_ARCH_SPARC T.KS_MODE_SPARC32 "add %g1, %g2, %g3";
+ test_ks T.KS_ARCH_SPARC T.KS_MODE_SPARC32 ~endian:T.KS_MODE_BIG_ENDIAN "add %g1, %g2, %g3";
+
+ test_ks T.KS_ARCH_SYSTEMZ T.KS_MODE_BIG_ENDIAN "a %r0, 4092(%r15, %r1)"