summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorStéphane Glondu <glondu@debian.org>2015-05-04 13:44:55 +0200
committerStéphane Glondu <glondu@debian.org>2015-05-04 13:44:55 +0200
commit1907d926ca753f5ce8a238708d419fc716f0d60b (patch)
tree2ad301f45f71d5bf3438386eb4fd0bcfdf5db066
Import ocaml-benchmark_1.3.orig.tar.gz
[dgit import orig ocaml-benchmark_1.3.orig.tar.gz]
Diffstat
-rw-r--r--API.odocl4
-rw-r--r--INSTALL.txt41
-rw-r--r--LICENSE.txt184
-rw-r--r--META12
-rw-r--r--Makefile55
-rw-r--r--README.md28
-rw-r--r--_oasis136
-rw-r--r--_tags65
-rw-r--r--benchmark.ml615
-rw-r--r--benchmark.mli230
-rw-r--r--benchmark.mllib4
-rw-r--r--examples/ar_ba.ml110
-rw-r--r--examples/composition.ml49
-rw-r--r--examples/func_record.ml39
-rw-r--r--examples/iter.ml45
-rw-r--r--examples/let_try.ml30
-rw-r--r--examples/loops.ml34
-rw-r--r--examples/match_array.ml40
-rw-r--r--examples/numbers.ml51
-rw-r--r--examples/regexps.ml49
-rw-r--r--examples/try_if.ml34
-rw-r--r--myocamlbuild.ml491
-rw-r--r--setup.ml6066
-rw-r--r--tests/long_run.ml16
24 files changed, 8428 insertions, 0 deletions
diff --git a/API.odocl b/API.odocl
new file mode 100644
index 0000000..271912b
--- /dev/null
+++ b/API.odocl
@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: 74575b23d5305310e904f87eb02ff980)
+Benchmark
+# OASIS_STOP
diff --git a/INSTALL.txt b/INSTALL.txt
new file mode 100644
index 0000000..a1decca
--- /dev/null
+++ b/INSTALL.txt
@@ -0,0 +1,41 @@
+
+ INSTALLATION INSTRUCTIONS
+----------------------------------------------------------------------
+
+This package uses OASIS to generate its build system. See section OASIS for
+full information.
+
+Dependencies
+============
+
+In order to compile this package, you will need:
+* ocaml for all, doc API
+* findlib
+
+Installing
+==========
+
+1. Run 'ocaml setup.ml -configure'
+2. Run 'ocaml setup.ml -build'
+3. Run 'ocaml setup.ml -install'
+
+If the libeary is already present on your computer, replace step 3
+with 'ocaml setup.ml -reinstall'.
+
+Some examples are compiled at the same time as the library. The
+executables are in _build/examples/.
+
+
+Uninstalling
+============
+
+1. Go to the root of the package
+2. Run 'ocaml setup.ml -uninstall'
+
+
+OASIS
+=====
+
+OASIS is a software that helps to write setup.ml using a simple '_oasis'
+configuration file. The generated setup only depends on standard OCaml
+installation, no additional library is required.
diff --git a/LICENSE.txt b/LICENSE.txt
new file mode 100644
index 0000000..087b7d0
--- /dev/null
+++ b/LICENSE.txt
@@ -0,0 +1,184 @@
+This Library is distributed under the terms of the GNU Lesser General
+Public License version 3 (included below) or, at your option, any
+later version.
+
+As a special exception to the GNU Lesser General Public License, you
+may link, statically or dynamically, a "work that uses the Library"
+with a publicly distributed version of the Library to produce an
+executable file containing portions of the Library, and distribute
+that executable file under terms of your choice, without any of the
+additional requirements listed in clause 6 of the GNU Lesser General
+Public License. By "a publicly distributed version of the Library",
+we mean either the unmodified Library as distributed, or a modified
+version of the Library that is distributed under the conditions
+defined in clause 3 of the GNU Library General Public License. This
+exception does not however invalidate any other reasons why the
+executable file might be covered by the GNU Lesser General Public
+License.
+
+
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+
+ This version of the GNU Lesser General Public License incorporates
+the terms and conditions of version 3 of the GNU General Public
+License, supplemented by the additional permissions listed below.
+
+ 0. Additional Definitions.
+
+ As used herein, "this License" refers to version 3 of the GNU Lesser
+General Public License, and the "GNU GPL" refers to version 3 of the GNU
+General Public License.
+
+ "The Library" refers to a covered work governed by this License,
+other than an Application or a Combined Work as defined below.
+
+ An "Application" is any work that makes use of an interface provided
+by the Library, but which is not otherwise based on the Library.
+Defining a subclass of a class defined by the Library is deemed a mode
+of using an interface provided by the Library.
+
+ A "Combined Work" is a work produced by combining or linking an
+Application with the Library. The particular version of the Library
+with which the Combined Work was made is also called the "Linked
+Version".
+
+ The "Minimal Corresponding Source" for a Combined Work means the
+Corresponding Source for the Combined Work, excluding any source code
+for portions of the Combined Work that, considered in isolation, are
+based on the Application, and not on the Linked Version.
+
+ The "Corresponding Application Code" for a Combined Work means the
+object code and/or source code for the Application, including any data
+and utility programs needed for reproducing the Combined Work from the
+Application, but excluding the System Libraries of the Combined Work.
+
+ 1. Exception to Section 3 of the GNU GPL.
+
+ You may convey a covered work under sections 3 and 4 of this License
+without being bound by section 3 of the GNU GPL.
+
+ 2. Conveying Modified Versions.
+
+ If you modify a copy of the Library, and, in your modifications, a
+facility refers to a function or data to be supplied by an Application
+that uses the facility (other than as an argument passed when the
+facility is invoked), then you may convey a copy of the modified
+version:
+
+ a) under this License, provided that you make a good faith effort to
+ ensure that, in the event an Application does not supply the
+ function or data, the facility still operates, and performs
+ whatever part of its purpose remains meaningful, or
+
+ b) under the GNU GPL, with none of the additional permissions of
+ this License applicable to that copy.
+
+ 3. Object Code Incorporating Material from Library Header Files.
+
+ The object code form of an Application may incorporate material from
+a header file that is part of the Library. You may convey such object
+code under terms of your choice, provided that, if the incorporated
+material is not limited to numerical parameters, data structure
+layouts and accessors, or small macros, inline functions and templates
+(ten or fewer lines in length), you do both of the following:
+
+ a) Give prominent notice with each copy of the object code that the
+ Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the object code with a copy of the GNU GPL and this license
+ document.
+
+ 4. Combined Works.
+
+ You may convey a Combined Work under terms of your choice that,
+taken together, effectively do not restrict modification of the
+portions of the Library contained in the Combined Work and reverse
+engineering for debugging such modifications, if you also do each of
+the following:
+
+ a) Give prominent notice with each copy of the Combined Work that
+ the Library is used in it and that the Library and its use are
+ covered by this License.
+
+ b) Accompany the Combined Work with a copy of the GNU GPL and this license
+ document.
+
+ c) For a Combined Work that displays copyright notices during
+ execution, include the copyright notice for the Library among
+ these notices, as well as a reference directing the user to the
+ copies of the GNU GPL and this license document.
+
+ d) Do one of the following:
+
+ 0) Convey the Minimal Corresponding Source under the terms of this
+ License, and the Corresponding Application Code in a form
+ suitable for, and under terms that permit, the user to
+ recombine or relink the Application with a modified version of
+ the Linked Version to produce a modified Combined Work, in the
+ manner specified by section 6 of the GNU GPL for conveying
+ Corresponding Source.
+
+ 1) Use a suitable shared library mechanism for linking with the
+ Library. A suitable mechanism is one that (a) uses at run time
+ a copy of the Library already present on the user's computer
+ system, and (b) will operate properly with a modified version
+ of the Library that is interface-compatible with the Linked
+ Version.
+
+ e) Provide Installation Information, but only if you would otherwise
+ be required to provide such information under section 6 of the
+ GNU GPL, and only to the extent that such information is
+ necessary to install and execute a modified version of the
+ Combined Work produced by recombining or relinking the
+ Application with a modified version of the Linked Version. (If
+ you use option 4d0, the Installation Information must accompany
+ the Minimal Corresponding Source and Corresponding Application
+ Code. If you use option 4d1, you must provide the Installation
+ Information in the manner specified by section 6 of the GNU GPL
+ for conveying Corresponding Source.)
+
+ 5. Combined Libraries.
+
+ You may place library facilities that are a work based on the
+Library side by side in a single library together with other library
+facilities that are not Applications and are not covered by this
+License, and convey such a combined library under terms of your
+choice, if you do both of the following:
+
+ a) Accompany the combined library with a copy of the same work based
+ on the Library, uncombined with any other library facilities,
+ conveyed under the terms of this License.
+
+ b) Give prominent notice with the combined library that part of it
+ is a work based on the Library, and explaining where to find the
+ accompanying uncombined form of the same work.
+
+ 6. Revised Versions of the GNU Lesser General Public License.
+
+ The Free Software Foundation may publish revised and/or new versions
+of the GNU Lesser General Public License from time to time. Such new
+versions will be similar in spirit to the present version, but may
+differ in detail to address new problems or concerns.
+
+ Each version is given a distinguishing version number. If the
+Library as you received it specifies that a certain numbered version
+of the GNU Lesser General Public License "or any later version"
+applies to it, you have the option of following the terms and
+conditions either of that published version or of any later version
+published by the Free Software Foundation. If the Library as you
+received it does not specify a version number of the GNU Lesser
+General Public License, you may choose any version of the GNU Lesser
+General Public License ever published by the Free Software Foundation.
+
+ If the Library as you received it specifies that a proxy can decide
+whether future versions of the GNU Lesser General Public License shall
+apply, that proxy's public statement of acceptance of any version is
+permanent authorization for you to choose that version for the
+Library.
diff --git a/META b/META
new file mode 100644
index 0000000..07349d2
--- /dev/null
+++ b/META
@@ -0,0 +1,12 @@
+# OASIS_START
+# DO NOT EDIT (digest: 74c7101d85ba97c754cd5b80df8b4dd1)
+version = "1.3"
+description = "Benchmark running times of code."
+requires = "unix"
+archive(byte) = "benchmark.cma"
+archive(byte, plugin) = "benchmark.cma"
+archive(native) = "benchmark.cmxa"
+archive(native, plugin) = "benchmark.cmxs"
+exists_if = "benchmark.cma"
+# OASIS_STOP
+
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..d040ace
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,55 @@
+PKGNAME = $(shell oasis query name)
+PKGVERSION = $(shell oasis query version)
+PKG_TARBALL = $(PKGNAME)-$(PKGVERSION).tar.gz
+
+DISTFILES = INSTALL.txt LICENSE.txt META Makefile README.md \
+ benchmark.mllib _tags _oasis API.odocl \
+ $(wildcard *.ml) $(wildcard *.mli) $(wildcard examples/*.ml) \
+ $(wildcard tests/*.ml)
+
+WEB = ocaml-benchmark.forge.ocamlcore.org:/home/groups/ocaml-benchmark/htdocs/
+
+
+.PHONY: all byte native configure doc install uninstall reinstall upload-doc
+
+all byte native setup.log: configure
+ ocaml setup.ml -build
+
+configure: setup.data
+setup.data: setup.ml
+ ocaml $< -configure --enable-examples --enable-tests
+
+setup.ml: _oasis
+ oasis setup
+
+doc install uninstall reinstall: setup.log
+ ocaml setup.ml -$@
+
+upload-doc: doc
+ scp -C -p -r _build/API.docdir $(WEB)
+
+# Make a tarball
+.PHONY: dist tar
+dist tar: $(DISTFILES)
+ mkdir $(PKGNAME)-$(PKGVERSION) ; \
+ cp -a --parents $(DISTFILES) $(PKGNAME)-$(PKGVERSION)/; \
+ tar -zcvf $(PKG_TARBALL) $(PKGNAME)-$(PKGVERSION); \
+ rm -rf $(PKGNAME)-$(PKGVERSION)
+
+# Release a Sourceforge tarball and publish the HTML doc
+.PHONY: web upload
+web: upload-doc
+ @ if [ -d web ] ; then \
+ $(SCP) web/*.html web/*.css web/*.jpg LICENSE.txt $(WEB) \
+ && echo "*** Published web site." ; \
+ fi
+
+
+.PHONY: clean distclean
+clean::
+ ocaml setup.ml -clean
+ $(RM) $(PKG_TARBALL)
+
+distclean:
+ ocaml setup.ml -distclean
+ $(RM) $(wildcard *.ba[0-9] *.bak *~ *.odocl)
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..3a173e9
--- /dev/null
+++ b/README.md
@@ -0,0 +1,28 @@
+
+Benchmark - measure/compare run-time of OCaml functions
+=======================================================
+
+ Copyright 2004-present, Christophe Troestler
+
+ Copyright 2002-2003, Doug Bagley
+ http://www.bagley.org/~doug/ocaml/
+
+
+Benchmark provides functions to measure and compare the run-time of
+functions. It is inspired by the Perl module of the same name.
+
+See the file INSTALL.txt for compiling and (un)installing.
+
+
+License
+-------
+
+This library is free software; you can redistribute it and/or modify
+it under the terms of the GNU Lesser General Public License version 3
+or later as published by the Free Software Foundation, with the
+special exception on linking described in file LICENSE.
+
+This library is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file
+LICENSE.txt for more details.
diff --git a/_oasis b/_oasis
new file mode 100644
index 0000000..c4f5fd4
--- /dev/null
+++ b/_oasis
@@ -0,0 +1,136 @@
+# -*-conf-*-
+OASISFormat: 0.3
+Name: benchmark
+Version: 1.3
+Synopsis: Benchmark running times of code.
+Authors: Christophe Troestler <Christophe.Troestler@umons.ac.be>
+License: LGPL-3.0 with OCaml linking exception
+Description: This module provides a set of tools to measure the running times
+ of your functions and to easily compare the results. A statistical
+ test is used to determine whether the results truly differ.
+Plugins: META (0.2)
+Homepage: http://ocaml-benchmark.forge.ocamlcore.org/
+
+Flag examples
+ Description: Whether to compile the examples.
+ Default: false
+
+Library benchmark
+ Path: .
+ BuildTools: ocamlbuild
+ Modules: Benchmark
+ BuildDepends: unix
+
+Document API
+ Title: API reference for Benchmark
+ Type: OCamlbuild (0.3)
+ InstallDir: $docdir/api
+ BuildTools: ocamldoc, ocamlbuild
+ XOCamlbuildPath: .
+ XOCamlbuildLibraries: benchmark
+
+# Examples
+Executable ar_ba
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: ar_ba.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark, bigarray
+ CompiledObject: best
+ Install: false
+
+Executable composition
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: composition.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark
+ CompiledObject: best
+ Install: false
+
+Executable iter
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: iter.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark, bigarray
+ CompiledObject: best
+ Install: false
+
+Executable let_try
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: let_try.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark, bigarray
+ CompiledObject: best
+ Install: false
+
+Executable loops
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: loops.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark
+ CompiledObject: best
+ Install: false
+
+Executable match_array
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: match_array.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark
+ CompiledObject: best
+ Install: false
+
+Executable numbers
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: numbers.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark
+ CompiledObject: best
+ Install: false
+
+Executable regexps
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: regexps.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark, str, pcre
+ CompiledObject: best
+ Install: false
+
+Executable try_if
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: try_if.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark, bigarray
+ CompiledObject: best
+ Install: false
+
+Executable func_record
+ Build$: flag(examples)
+ Path: examples/
+ MainIs: func_record.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark
+ CompiledObject: best
+ Install: false
+
+# Tests
+Executable long_run
+ Build$: flag(tests)
+ Path: tests
+ MainIs: long_run.ml
+ BuildTools: ocamlbuild
+ BuildDepends: benchmark, unix
+ CompiledObject: best
+ Install: false
+
+SourceRepository trunk
+ Type: svn
+ Location: svn://scm.ocamlcore.org/svn/ocaml-benchmark/trunk
+ Browser: https://forge.ocamlcore.org/scm/browser.php?group_id=197
diff --git a/_tags b/_tags
new file mode 100644
index 0000000..c4c77a6
--- /dev/null
+++ b/_tags
@@ -0,0 +1,65 @@
+# OASIS_START
+# DO NOT EDIT (digest: afd393a5850380fa4cf24d59c39177a8)
+# 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
+<**/.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 benchmark
+"benchmark.cmxs": use_benchmark
+<*.ml{,i}>: pkg_unix
+# Executable ar_ba
+<examples/ar_ba.{native,byte}>: use_benchmark
+<examples/ar_ba.{native,byte}>: pkg_unix
+<examples/ar_ba.{native,byte}>: pkg_bigarray
+# Executable composition
+<examples/composition.{native,byte}>: use_benchmark
+<examples/composition.{native,byte}>: pkg_unix
+# Executable iter
+<examples/iter.{native,byte}>: use_benchmark
+<examples/iter.{native,byte}>: pkg_unix
+<examples/iter.{native,byte}>: pkg_bigarray
+# Executable let_try
+<examples/let_try.{native,byte}>: use_benchmark
+<examples/let_try.{native,byte}>: pkg_unix
+<examples/let_try.{native,byte}>: pkg_bigarray
+# Executable loops
+<examples/loops.{native,byte}>: use_benchmark
+<examples/loops.{native,byte}>: pkg_unix
+# Executable match_array
+<examples/match_array.{native,byte}>: use_benchmark
+<examples/match_array.{native,byte}>: pkg_unix
+# Executable numbers
+<examples/numbers.{native,byte}>: use_benchmark
+<examples/numbers.{native,byte}>: pkg_unix
+# Executable regexps
+<examples/regexps.{native,byte}>: use_benchmark
+<examples/regexps.{native,byte}>: pkg_unix
+<examples/regexps.{native,byte}>: pkg_str
+<examples/regexps.{native,byte}>: pkg_pcre
+<examples/*.ml{,i}>: pkg_str
+<examples/*.ml{,i}>: pkg_pcre
+# Executable try_if
+<examples/try_if.{native,byte}>: use_benchmark
+<examples/try_if.{native,byte}>: pkg_unix
+<examples/try_if.{native,byte}>: pkg_bigarray
+<examples/*.ml{,i}>: pkg_bigarray
+# Executable func_record
+<examples/func_record.{native,byte}>: use_benchmark
+<examples/func_record.{native,byte}>: pkg_unix
+<examples/*.ml{,i}>: use_benchmark
+<examples/*.ml{,i}>: pkg_unix
+# Executable long_run
+<tests/long_run.{native,byte}>: use_benchmark
+<tests/long_run.{native,byte}>: pkg_unix
+<tests/*.ml{,i}>: use_benchmark
+<tests/*.ml{,i}>: pkg_unix
+# OASIS_STOP
diff --git a/benchmark.ml b/benchmark.ml
new file mode 100644
index 0000000..c8c956f
--- /dev/null
+++ b/benchmark.ml
@@ -0,0 +1,615 @@
+(* File: benchmark.ml
+ For comparing runtime of functions
+ *********************************************************************
+
+ Copyright 2004-present, Troestler Christophe
+ Christophe.Troestler(at)umh.ac.be
+
+ Copyright 2002-2003, Doug Bagley
+ http://www.bagley.org/~doug/ocaml/
+ Initially based on the Perl module Benchmark.pm by Jarkko Hietaniemi
+ and Tim Bunce
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public License
+ version 3 as published by the Free Software Foundation, with the
+ special exception on linking described in file LICENSE.
+
+ This library is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file
+ LICENSE.txt for more details.
+*)
+
+open Printf
+
+type t = {
+ wall : float;
+ utime : float;
+ stime : float;
+ cutime : float;
+ cstime : float;
+ iters : Int64.t;
+ (* As of version 0.8, one had to change [iter] from [int] because,
+ as machines run faster, a number of iterations ~ 2^29 is no
+ longer enough (2^29 is the largest > 0 power of 2 that [int] can
+ hold on a 32 bits platform. *)
+}
+
+type style = No_child | No_parent | All | Auto | Nil
+
+let null_t =
+ { wall = 0.; utime = 0.; stime = 0.; cutime = 0.; cstime = 0.; iters = 0L }
+
+let make n =
+ let tms = Unix.times() in
+ { wall = Unix.gettimeofday();
+ utime = tms.Unix.tms_utime; stime = tms.Unix.tms_stime;
+ cutime = tms.Unix.tms_cutime; cstime = tms.Unix.tms_cstime;
+ iters = n }
+
+let add a b =
+ { wall = a.wall +. b.wall; utime = a.utime +. b.utime;
+ stime = a.stime +. b.stime; cutime = a.cutime +. b.cutime;
+ cstime = a.cstime +. b.cstime; iters = Int64.add a.iters b.iters }
+
+let sub a b =
+ { wall = a.wall -. b.wall; utime = a.utime -. b.utime;
+ stime = a.stime -. b.stime; cutime = a.cutime -. b.cutime;
+ cstime = a.cstime -. b.cstime; iters = Int64.sub a.iters b.iters }
+
+(* It may happen that, because of slight variations, the running time
+ of a fast running test is less than the running time of the null
+ loop. Returning a negative result is obviously ridiculous, thus
+ one returns 0. *)
+let ( -- ) a b = if (a:float) > b then a -. b else 0.
+let pos_sub a b =
+ { wall = a.wall -- b.wall; utime = a.utime -- b.utime;
+ stime = a.stime -- b.stime; cutime = a.cutime -- b.cutime;
+ cstime = a.cstime -- b.cstime; iters = Int64.sub a.iters b.iters }
+
+
+let cpu_process b = b.utime +. b.stime
+let cpu_childs b = b.cutime +. b.cstime
+let cpu_all b = b.utime +. b.stime +. b.cutime +. b.cstime
+
+(* Return a formatted representation of benchmark structure according
+ to [style]. Default values for presentation parameters are set
+ here. *)
+let to_string ?(style=Auto) ?(fwidth=5) ?(fdigits=2) b =
+ let pt = cpu_process b
+ and ct = cpu_childs b in
+ let style =
+ if style = Auto then if ct > 1e-10 then All else No_child else style in
+ let iter_info t =
+ if b.iters > 0L && t > 0.0 then
+ sprintf " @ %*.*f/s (n=%Ld)" fwidth fdigits
+ (Int64.to_float b.iters /. t) b.iters
+ else "" in
+ let f x = sprintf "%*.*f" fwidth fdigits x in
+ match style with
+ | All ->
+ sprintf "%s WALL (%s usr %s sys + %s cusr %s csys = %s CPU)%s"
+ (f b.wall) (f b.utime) (f b.stime) (f b.cutime) (f b.cstime)
+ (f(pt +. ct)) (iter_info pt)
+ | No_child ->
+ sprintf "%s WALL (%s usr + %s sys = %s CPU)%s"
+ (f b.wall) (f b.utime) (f b.stime) (f pt) (iter_info pt)
+ | No_parent ->
+ sprintf "%s WALL (%s cusr + %s csys = %s CPU)%s"
+ (f b.wall) (f b.cutime) (f b.cstime) (f ct) (iter_info ct)
+ | Nil -> ""
+ | Auto -> assert false
+
+
+(* Returns a string in minutes-seconds of a time [t >= 0] given in
+ seconds. *)
+let rec string_of_time t =
+ if t = 0 || t = 1 then string_of_int t ^ "s"
+ else if t < 60 then string_of_int t ^ "s"
+ else if t < 120 then "1m " ^ string_of_time(t - 60)
+ else string_of_int(t / 60) ^ "m " ^ string_of_time(t mod 60)
+
+(* The time [t >= 0] is rounded to the nearest integer: *)
+let string_of_time t = string_of_time(truncate(t +. 0.5))
+
+
+type samples = (string * t list) list
+
+let by_name (s1, _) (s2, _) = compare (s1:string) s2
+
+let merge (l1:samples) (l2:samples) =
+ (* [do_merge] assumes [l1] and [l2] are sorted. *)
+ let rec do_merge acc l1 l2 =
+ match l1, l2 with
+ | _, [] -> acc @ l1
+ | [], _ -> acc @ l2
+ | ((n1, t1) as d1) :: tl1, ((n2, t2) as d2) :: tl2 ->
+ let sgn = compare n1 n2 in
+ if sgn = 0 then do_merge ((n1, t1 @ t2) :: acc) tl1 tl2
+ else if sgn < 0 then do_merge (d1 :: acc) tl1 l2
+ else do_merge (d2 :: acc) l1 tl2 in
+ do_merge [] (List.sort by_name l1) (List.sort by_name l2)
+
+
+let max_iter = Int64.add (Int64.of_int max_int) 1L
+ (* even if [int] is 63 bits, [(max_iter:Int64.t) > 0] *)
+
+(* [runloop n_iters n f x] returns the elapsed time of running [n >=
+ 0L] times [f] with the argument [x]. The structure returned
+ declare [n_iter] iterations. *)
+let runloop n_iters n f x =
+ let n' = Int64.div n max_iter in
+ if n' >= max_iter then
+ invalid_arg "Benchmark.runloop: number of iterations too large";
+ let n1 = Int64.to_int n'
+ and n0 = Int64.to_int(Int64.rem n max_iter) in
+ let t0 = ref (make 0L) in
+ let tbase = !t0.utime in
+ (* Wait for user timer to tick. This makes the error range more
+ like -0.01, +0. If we don't wait, then it's more like -0.01,
+ +0.01. *)
+ while tbase = (!t0).utime do t0 := make 0L done;
+ (* Loop over function we are timing [n] times (looping on int64
+ quantities takes too long, this is why we use composite loops). *)
+ for i = 1 to n1 do
+ for j = 0 to max_int do ignore(f x) done; (* [max_iter] runs *)
+ done;
+ for i = 1 to n0 do ignore(f x) done;
+ let t1 = make n_iters in
+ pos_sub t1 !t0
+
+(* time a null-loop; no iter count *)
+let null_loop n = runloop 0L n ignore ()
+
+(* Run function [f] count times, return time taken (all times
+ garanteed to be [>= 0.]) *)
+let timeit n f x =
+ let bn = null_loop n in
+ let bm = runloop n n f x in
+ pos_sub bm bn (* time of function minus null-loop *),
+ bn.wall +. bm.wall (* how much the used had to wait *)
+
+
+type printer = {
+ print_indent : string -> unit; (* prefix, flushes *)
+ print : string -> unit; (* No prefix but flushes *)
+}
+
+(* [print_run ff bm] prints the list of timings [bm] according to the
+ style defined by the optional parameters. *)
+let print_run out ?(min_count=4L) ?(min_cpu=0.4) ~style ?fwidth ?fdigits b =
+ out.print_indent(to_string ~style ?fwidth ?fdigits b ^ "\n");
+ if b.iters < min_count || cpu_all b < min_cpu
+ || (b.wall < 1. && b.iters < 1000L)
+ then out.print_indent "(warning: too few iterations for a reliable count)\n"
+
+
+let latency n out ?min_count ?min_cpu ~style ?fwidth ?fdigits
+ ~repeat name f x =
+ let rec loop nrep acc =
+ if nrep < 1 then acc
+ else (
+ Gc.compact(); (* Reclaim memory to avoid undue GC during the test. *)
+ let bm, _ = timeit n f x in
+ print_run out ?min_count ?min_cpu ~style ?fwidth ?fdigits bm;
+ loop (nrep - 1) (bm :: acc)
+ ) in
+ loop repeat []
+
+
+(* Read the code from bottom to top: [min_iter] determines the minimal
+ number of iterations to have a significant timing, then
+ [estimate_niter] estimate by linear interpolation the number of
+ iter to run [> tmin] and then the test is performed. *)
+let throughput tmin out ?min_count ?min_cpu ~style ?fwidth ?fdigits
+ ~repeat name f x =
+ (* Run [f] for [niter] times and complete with >= [nmin] iterations
+ (estimated by linear interpolation) to run >= [tmin]. *)
+ let rec run_test nmin niter bm_init total_wall =
+ let bm, wall = timeit niter f x in
+ let bm = add bm_init bm in
+ let tn = cpu_process bm in
+ let total_wall = total_wall +. wall in
+ if tn >= tmin then (
+ print_run out ?min_count ?min_cpu ~style ?fwidth ?fdigits bm;
+ bm, total_wall
+ )
+ else
+ (* FIXME *)
+ let n = Int64.of_float((tmin /. tn -. 1.) *. Int64.to_float bm.iters) in
+ run_test nmin (max nmin n) bm total_wall in
+ (* Repeat the test [nrep] times and return the list of results. *)
+ let rec repeat_test nrep acc nmin niter wall_estim =
+ if nrep < 1 then acc else (
+ Gc.compact(); (* Reclaim memory to avoid undue GC during the test. *)
+ let bm, wall = run_test nmin niter null_t 0. in
+ let wall_estim =
+ if wall > wall_estim +. 60. then (
+ out.print_indent("(Estimated time for subsequent runs: "
+ ^ (string_of_time wall) ^ ")\n");
+ wall
+ )
+ else wall_estim in
+ repeat_test (nrep - 1) (bm :: acc) nmin niter wall_estim
+ ) in
+ (* Estimate number of iter > [nmin] to have a running time >=
+ [tmin]. The initial estimate is [n] running [tn] secs. Linear
+ estimates bear a 5% fudge to improve the overall responsiveness. *)
+ let tpra = 0.1 *. tmin (* Target/time practice *) in
+ let rec estimate_niter nmin n tn wall =
+ if tn >= tpra then
+ (* FIXME: *)
+ (* lin estim *)
+ let niter = Int64.of_float(Int64.to_float n *. (1.05 *. tmin /. tn)) in
+ let wall_estim = wall *. (1.05 *. tmin /. tn) in
+ if wall_estim >= 60. then
+ out.print_indent("(Estimated time for each run: "
+ ^ (string_of_time wall_estim) ^ ")\n");
+ repeat_test repeat [] nmin (max nmin niter) wall_estim
+ else
+ (* lin estim *)
+ let new_n = Int64.of_float(Int64.to_float n *. 1.05 *. tpra /. tn) in
+ let new_bn, new_wall = timeit new_n f x in
+ let new_tn = cpu_process new_bn in
+ let n = (* make sure we make progress *)
+ if new_tn > 1.2 *. tn then new_n
+ else Int64.of_float(1.1 *. Int64.to_float n +. 1.) (* FIXME *) in
+ estimate_niter nmin n new_tn new_wall in
+ (* Determine the minimum number of iterations to run >= 0.1 sec
+ (whatever [tmin]). Inform the user if it takes too long. *)
+ let rec min_iter n ~takes_long:previous_took_long total_wall =
+ if n <= 0L then
+ failwith "throughput: number of iterations too large for Int64.t storage";
+ let bm, wall = timeit n f x in
+ let tn = cpu_process bm in
+ let total_wall = total_wall +. wall in
+ if tn < 0.1 then (
+ let takes_long = total_wall >= 30. in
+ if takes_long then (
+ if total_wall >= 120. then (
+ out.print " canceled)\n";
+ failwith(sprintf "Benchmark.throughputN: wall time is %g while \
+ CPU time is %g. Do you use \"sleep\"?" total_wall tn)
+ )
+ else if previous_took_long then out.print "." else
+ out.print_indent("(Determining how many runs to perform, \
+ please be patient...");
+ );
+ let twice_n = Int64.shift_left n 1 in
+ min_iter twice_n ~takes_long total_wall
+ )
+ else (
+ if previous_took_long then out.print ")\n";
+ if tn < tmin then estimate_niter n n tn wall (* tn > 0.1 *)
+ else ( (* minimal [n] good for [tmin], use the above measurement
+ for the first run. *)
+ print_run out ?min_count ?min_cpu ~style ?fwidth ?fdigits bm;
+ repeat_test (repeat - 1) [bm] n n wall
+ )
+ ) in
+ min_iter 1L ~takes_long:false 0.
+
+
+(* Make a print function that prefixes each output except the first
+ one by [nspace] spaces. *)
+let make_printer nspace =
+ let first = ref true in
+ let prefix = String.make nspace ' ' in
+ let print s = print_string s; flush stdout in
+ let print_indent s =
+ if !first then first := false else print_string prefix;
+ print s in
+ { print_indent = print_indent; print = print; }
+
+let null_printer = { print_indent = (fun _ -> ()); print = (fun _ -> ()) }
+
+
+(* Generic interface for performing measurments on a list of functions *)
+let testN ~test default_f_name ?min_count ?min_cpu ~style
+ ?fwidth ?fdigits ~repeat funs =
+ let length_name =
+ List.fold_left (fun m (n,_,_) -> max m (String.length n)) 0 funs in
+ let result_of (name, f, x) =
+ printf "%*s: %!" length_name (if name = "" then default_f_name else name);
+ let out = if style = Nil then null_printer
+ else make_printer (length_name + 2) in
+ let bm = test out ?min_count ?min_cpu ~style ?fwidth ?fdigits
+ ~repeat name f x in
+ (name, bm) in
+ List.map result_of funs
+
+let rec string_of_names funs =
+ String.concat ", " (List.map (fun (a,_,_) -> sprintf "%S" a) funs)
+
+
+let latencyN ?min_cpu ?(style=Auto) ?fwidth ?fdigits ?(repeat=1) n funs =
+ if n < 4L then invalid_arg "Benchmark.latencyN: n < 4";
+ if style <> Nil then (
+ printf "Latencies for %Ld iterations of %s%s:\n%!" n
+ (string_of_names funs)
+ (if repeat > 1 then sprintf " (%i runs)" repeat else "");
+ );
+ testN ~test:(latency n) (sprintf "[run %Ld times]" n)
+ ?min_cpu ~style ?fwidth ?fdigits ~repeat funs
+
+let latency1 ?min_cpu ?style ?fwidth ?fdigits ?repeat n ?(name="") f x =
+ if n < 4L then invalid_arg "Benchmark.latency1";
+ latencyN ?min_cpu ?style ?fwidth ?fdigits ?repeat n [(name, f, x)]
+
+
+let throughputN ?min_count ?(style=Auto) ?fwidth ?fdigits ?(repeat=1) n funs =
+ if n <= 0 then invalid_arg "Benchmark.throughputN: n <= 0";
+ let tmin = float n in
+ if style <> Nil then (
+ printf "Throughputs for %s%s running%s for at least %g CPU second%s:\n%!"
+ (string_of_names funs)
+ (if List.length funs > 1 then " each" else "")
+ (if repeat > 1 then sprintf " %i times" repeat else "")
+ tmin (if n > 1 then "s" else "");
+ );
+ testN ~test:(throughput tmin) (sprintf "[run > %3.1g secs]" tmin)
+ ?min_count ~style ?fwidth ?fdigits ~repeat funs
+
+let throughput1 ?min_count ?style ?fwidth ?fdigits ?repeat n ?(name="") f x =
+ if n <= 0 then invalid_arg "Benchmark.throughput1: n <= 0";
+ throughputN ?min_count ?style ?fwidth ?fdigits ?repeat n [(name, f, x)]
+
+
+(* Statistical tests and comparison table
+ ***********************************************************************)
+
+(* Utility functions *)
+let list_mapi f =
+ let rec loop i = function
+ | [] -> []
+ | a::l -> let r = f i a in r :: loop (i + 1) l in
+ loop 0
+
+let list_iteri f =
+ let rec loop i = function
+ | [] -> ()
+ | a::l -> let () = f i a in loop (i + 1) l in
+ loop 0
+
+let is_nan x = (classify_float x = FP_nan)
+
+
+(* [log_gamma x] computes the logarithm of the Gamma function at [x]
+ using Lanczos method. It is assumed [x > 0.].
+
+ See e.g. http://home.att.net/~numericana/answer/info/godfrey.htm *)
+let log_gamma =
+ let c = [| 1.000000000000000174663;
+ 5716.400188274341379136;
+ -14815.30426768413909044;
+ 14291.49277657478554025;
+ -6348.160217641458813289;
+ 1301.608286058321874105;
+ -108.1767053514369634679;
+ 2.605696505611755827729;
+ -0.7423452510201416151527e-2;
+ 0.5384136432509564062961e-7;
+ -0.4023533141268236372067e-8 |] in
+ let c_last = Array.length c - 1 in
+ let g = float(c_last - 1) in
+ let sqrt2pi = sqrt(8. *. atan 1.) in
+ let rec sum i den s =
+ if i > 0 then sum (i - 1) (den -. 1.) (s +. c.(i) /. den)
+ else c.(0) +. s in
+ fun x ->
+ assert(x > 0.);
+ let xg = x +. g in
+ let xg_5 = xg -. 0.5 in
+ log(sqrt2pi *. sum c_last xg 0.) +. (x -. 0.5) *. log xg_5 -. xg_5
+
+(* Beta function. It is assumed [a > 0. && b > 0.]. *)
+let beta a b =
+ assert(a > 0. && b > 0.);
+ exp(log_gamma a +. log_gamma b -. log_gamma(a +. b))
+
+(* [betai x a b] returns the value of the incomplete Beta function
+ I_x(a,b). It is evaluated through the continued fraction expansion
+ (see e.g. Numerical Recipies, 6.4):
+
+ x^a (1-x)^b [ 1 d1 d2 ]
+ I_x(a,b) = ----------- [ -- -- -- ... ]
+ a B(a,b) [ 1+ 1+ 1+ ]
+
+ where B(a,b) is the beta function and
+
+ m (b-m) x - (a + m)(a + b + m) x
+ d_2m = -------------------- d_(2m+1) = ----------------------
+ (a + 2m - 1)(a + 2m) (a + 2m)(a + 2m + 1)
+
+ The modified Lentz's method is used for the continued fraction (see
+ NR, section 5.2) in routine [betai_cf].
+*)
+let max_tiny x = max 1e-30 x (* to avoid null divisors *)
+
+let betai_cf_eps = epsilon_float
+
+let betai_cf x a b =
+ let apb = a +. b
+ and ap1 = a +. 1.
+ and am1 = a -. 1. in
+ let rec lentz m c d f =
+ let m2 = 2. *. m in
+ (* Even rec step d_2m *)
+ let cf_d2m = m *. (b -. m) *. x /. ((am1 +. m2) *. (a +. m2)) in
+ let d = 1. /. max_tiny(1. +. cf_d2m *. d)
+ and c = max_tiny(1. +. cf_d2m /. c) in
+ let f = f *. d *. c in
+ (* Odd rec step d_2m+1 *)
+ let cf_d2m1 = -. (a +. m) *. (apb +. m) *. x
+ /. ((a +. m2) *. (ap1 +. m2)) in
+ let d = 1. /. max_tiny(1. +. cf_d2m1 *. d)
+ and c = max_tiny(1. +. cf_d2m1 /. c) in
+ let delta = c *. d in
+ let f = f *. delta in
+ if abs_float(delta -. 1.) < betai_cf_eps then f
+ else lentz (m +. 1.) c d f in
+ (* Initialize Lentz's method with C2=1, D2 (step 2) *)
+ let d2 = 1. /. max_tiny(1. -. apb *. x /. ap1) in
+ lentz 1. 1. d2 d2
+
+let betai x a b =
+ assert(a > 0. && b > 0.);
+ if x < 0. || x > 1. then invalid_arg "betai";
+ if x = 0. then 0.
+ else if x = 1. then 1.
+ else
+ let m = exp(log_gamma(a +. b) -. log_gamma a -. log_gamma b
+ +. a *. log x +. b *. log(1. -. x)) in
+ if x < (a +. 1.) /. (a +. b +. 2.)
+ then m *. betai_cf x a b /. a
+ else 1. -. m *. betai_cf (1. -. x) b a /. b
+
+(* [cpl_student_t t nu] compute the "complement" of the Student's
+ distribution: 1 - A(t|nu). It is used to compute the significance
+ of probabilistic tests. *)
+let cpl_student_t t nu =
+ betai (nu /. (nu +. t *. t)) (0.5 *. nu) 0.5
+
+
+(* [comp_rates (name, bm)] computes the number, average and standard
+ deviation of rates from the list of timings [bm]. If bm = [x(1);
+ x(2);...; x(n)], the algorithm is
+
+ m(1) = x(1) m(k) = m(k-1) + (x(k) - m(k-1))/k
+ s(1) = 0 s(k) = s(k-1) + (x(k) - m(k-1))(x(k) - m(k))
+
+ One proves by recurrence that
+
+ m(k) = sum(x(i) : 1 <= i <= k) / k
+ s(k) = sum(x(i)**2 : 1 <= i <= k) - k m(k)**2
+ = sum( (x(i) - m(k))**2 : 1 <= i <= k)
+
+ Cf. Knuth, Seminumerical algorithms. *)
+let comp_rates cpu (name, bm) =
+ let rec loop n m s = function
+ | [] -> (name, n, m, s)
+ | b :: tl ->
+ let rate = Int64.to_float b.iters /. cpu b in
+ let n' = n + 1 in
+ let m' = m +. (rate -. m) /. (float n') in
+ let s' = s +. (rate -. m) *. (rate -. m') in
+ loop n' m' s' tl in
+ match bm with
+ | [] -> (name, 0, nan, 0.) (* NaN used for no-data *)
+ | b :: tl -> loop 1 (Int64.to_float b.iters /. (cpu b +. 1e-15)) 0. tl
+
+(* Compare rates *)
+let by_rates (_,_,r1,_) (_,_,r2,_) = compare (r1:float) r2
+
+(* Check whether two rates are significantly different. With a small
+ [significance], a [true] returned value means that the rates are
+ significantly different. [n1] is the number of repetitions of the
+ test1, [r1] is its mean rate and [s1] its standard deviation.
+ [n2], [r2] and [s2] are similar for the test2. *)
+let different_rates significance n1 r1 s1 n2 r2 s2 =
+ assert(n1 > 0 && n2 > 0);
+ if n1 = 1 && n2 = 1 then true (* no info about distribution, assume
+ they really are. *)
+ else
+ let df = float(n1 + n2 - 2) (* >= 1. *)
+ and n1 = float n1
+ and n2 = float n2 in
+ let sD = sqrt((s1 +. s2) /. df *. (1. /. n1 +. 1. /. n2)) in
+ let t = (r1 -. r2) /. sD in
+ cpl_student_t t df <= significance
+
+
+(* [string_of_rate display_as_rate confidence n r s] *)
+let string_of_rate display_as_rate =
+ let per_sec = if display_as_rate then "/s" else "" in
+ fun confidence n r s ->
+ (* Assume Gaussian distribution *)
+ let sigma = sqrt(s/. float n) in
+ let err = confidence *. sigma (* FIXME *) in
+ let a, err =
+ if display_as_rate then r, err else
+ let n = 1. /. r in (n, n *. n *. err) (* Taylor of order 1 of 1/r *) in
+ let p prec =
+ if sigma < 1e-15 then (sprintf " %0.*f%s" prec a per_sec, "")
+ else (sprintf " %0.*f+-" prec a, sprintf "%.*f%s" prec err per_sec) in
+ if a >= 100. then p 0
+ else if a >= 10. then p 1
+ else if a >= 1. then p 2
+ else if a >= 0.1 then p 3
+ else if sigma < 1e-15 then (sprintf " %g%s" a per_sec, "")
+ else (sprintf " %g+-" a, sprintf "%g%s" err per_sec)
+
+
+(* print results of a bench_many run *)
+(* results = [(name, bm); (name, bm); (name, bm); ...] *)
+let tabulate ?(no_parent=false) ?(confidence=0.95) results =
+ if confidence < 0. || confidence > 1. then
+ invalid_arg "Benchmark.tabulate: confidence < 0. or > 1.";
+ let len = List.length results in
+ if len = 0 then invalid_arg "Benchmark.tabulate: empty list of results";
+ (* Compute (name, rate, sigma) for all results and sort them by rates *)
+ let cpu = if no_parent then cpu_childs else cpu_process in
+ let rates = List.sort by_rates (List.map (comp_rates cpu) results) in
+ (* Decide whether to display by rates or seconds *)
+ let display_as_rate =
+ let (_,_,r,_) = List.nth rates (len / 2) in r > 1. in
+ (*
+ * Compute rows
+ *)
+ let top_row = "" :: (if display_as_rate then " Rate" else " s/iter")
+ :: "" :: (List.map (fun (s,_,_,_) -> " " ^ s) rates) in
+ (* Initialize the widths of the columns from the top row *)
+ let col_width = Array.of_list (List.map String.length top_row) in
+ (* Build all the data [rows], each starting with separation space *)
+ let string_of_rate = string_of_rate display_as_rate in
+ let make_row i (row_name, row_n, row_rate, row_s) =
+ (* Column 0: test name *)
+ col_width.(0) <- max (String.length row_name) col_width.(0);
+ (* Column 1 & 2: performance *)
+ let ra, ra_err = string_of_rate confidence row_n row_rate row_s in
+ col_width.(1) <- max (String.length ra) col_width.(1);
+ col_width.(2) <- max (String.length ra_err) col_width.(2);
+ (* Columns 3..(len + 2): performance ratios *)
+ let make_col j (col_name, col_n, col_rate, col_s) =
+ let ratio =
+ if i = j || is_nan row_rate || is_nan col_rate then "--" else
+ let p = 100. *. row_rate /. col_rate -. 100. in
+ if p = 0. || different_rates (1. -. confidence)
+ row_n row_rate row_s col_n col_rate col_s
+ then sprintf " %.0f%%" p
+ else sprintf " [%.0f%%]" p in
+ col_width.(j + 3) <- max (String.length ratio) col_width.(j + 3);
+ ratio in
+ row_name :: ra :: ra_err :: (list_mapi make_col rates) in
+ let rows = list_mapi make_row rates in
+ (*
+ * Equalize column widths in the chart as much as possible without
+ * exceeding 80 characters. This does not use or affect cols 0, 1 and 2.
+ *)
+ (* Build an array of indexes [nth.(0..(len-1))] to access
+ [col_width.(3..(len+2))] in nondecreasing order. *)
+ let nth = Array.init len (fun i -> i + 3) in
+ let by_width i1 i2 = compare col_width.(i1) col_width.(i2) in
+ Array.sort by_width nth;
+ let max_width = col_width.(nth.(len - 1)) in
+ let rec stretcher min_width total =
+ if min_width < max_width then stretch_min 0 min_width total
+ and stretch_min i min_width total = (* try to stretch col [i] *)
+ if total < 80 then begin
+ if i < len && col_width.(nth.(i)) = min_width then begin
+ col_width.(nth.(i)) <- col_width.(nth.(i)) + 1;
+ stretch_min (i + 1) min_width (total + 1) (* stretch next col? *)
+ end
+ else stretcher (min_width + 1) total (* try again to stretch *)
+ end in
+ stretcher col_width.(nth.(0)) (Array.fold_left ( + ) 0 col_width);
+ (*
+ * Display the table
+ *)
+ let row_formatter row =
+ list_iteri (fun i d -> printf "%*s" col_width.(i) d) row;
+ print_string "\n" in
+ row_formatter top_row;
+ List.iter row_formatter rows;
+ flush stdout
diff --git a/benchmark.mli b/benchmark.mli
new file mode 100644
index 0000000..514ea20
--- /dev/null
+++ b/benchmark.mli
@@ -0,0 +1,230 @@
+(* File: benchmark.mli
+
+ Copyright Aug. 2004-present by Troestler Christophe
+ Christophe.Troestler(at)umons.ac.be
+
+ Copyright 2002-2003, Doug Bagley
+ http://www.bagley.org/~doug/ocaml/
+ Based on the Perl module Benchmark.pm by Jarkko Hietaniemi and Tim Bunce
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public License
+ version 3 as published by the Free Software Foundation, with the
+ special exception on linking described in file LICENSE.txt.
+
+ This library is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the file
+ LICENSE.txt for more details.
+*)
+
+(** Benchmark running times of code.
+
+ This module implements benchmarking functions for measuring the
+ run-time of one or many functions using latency (multiple
+ repetitions) or throughput (repeat until some time period has
+ passed) tests.
+
+ {b Examples:}
+ Run the function [f] with input [5000] for [10] iterations and
+ print the CPU times:
+ {[
+ Benchmark.latency1 10 f 5000 ]}
+
+ Run the tests [foo], [bar] and [baz] three times for at least [8]
+ seconds each, printing the results of each test, and then print a
+ cross tabulation of the results:
+ {[
+ open Benchmark
+ let res = throughputN ~repeat:3 8 [("foo", foo, 1000000);
+ ("bar", bar, 2000000);
+ ("baz", baz, 3000000); ] in
+ print_newline();
+ tabulate res ]}
+
+ Time how long it takes to some piece of code:
+ {[
+ let t0 = Benchmark.make 0L in
+ (* do something here *)
+ let b = Benchmark.sub (Benchmark.make 0L) t0 in
+ print_endline "Benchmark results:";
+ print_endline (Benchmark.to_string b) ]}
+ *)
+
+
+(** {2 Timing and samples structures} *)
+
+(** The information returned by timing tests. *)
+type t = {
+ wall : float; (** Wallclock time (in seconds) *)
+ utime : float; (** This process User CPU time (in seconds) *)
+ stime : float; (** This process System CPU time (in seconds) *)
+ cutime : float; (** Child process User CPU time (in seconds) *)
+ cstime : float; (** Child process System CPU time (in seconds) *)
+ iters : Int64.t; (** Number of iterations. *)
+}
+
+(** Style of the output. *)
+type style =
+ | No_child (** Do not print child CPU times *)
+ | No_parent (** Do not print parent CPU times *)
+ | All (** Print parent and child CPU times *)
+ | Auto (** Same as [No_child] unless there is child CPU used *)
+ | Nil (** Print nothing *)
+
+val make : Int64.t -> t
+ (** [Benchmark.make n] create a new {!Benchmark.t} structure with
+ current time values and [n] iterations. Only the integer part of
+ [n] is used, the fractional part is ignored. *)
+
+val add : t -> t -> t
+ (** [Benchmark.add b1 b2] add {!Benchmark.t} structure [b1] to [b2]. *)
+
+val sub : t -> t -> t
+ (** [Benchmark.sub b1 b2] subtract {!Benchmark.t} structure [b2]
+ from [b1]. *)
+
+val to_string : ?style:style -> ?fwidth:int -> ?fdigits:int -> t -> string
+ (** [Benchmark.to_string ?style ?fwidth ?fdigits b] converts the
+ {!Benchmark.t} structure to a formatted string.
+
+ @param style printing style (default: [Auto])
+ @param fwidth number of chars reserved for the numbers (default: [5])
+ @param fdigits number of fractional digits of the numbers (default: [2])
+ *)
+
+type samples = (string * t list) list
+ (** Association list that links the names of the tests to the list
+ of their timings. *)
+
+val merge : samples -> samples -> samples
+ (** [merge l1 l2] merges the two association lists of timings [l1]
+ and [l2] into a single one, concatenating the timings for the same
+ names of [l1] and [l2]. *)
+
+
+(** {2 Timing functions} *)
+
+val throughputN :
+ ?min_count:Int64.t ->
+ ?style:style ->
+ ?fwidth:int ->
+ ?fdigits:int ->
+ ?repeat:int ->
+ int -> (string * ('a -> 'b) * 'a) list -> samples
+ (** [Benchmark.throughputN ?min_count ?style ?fwidth ?fdigits t
+ funs] runs each function in list [funs] for at least [t > 0]
+ seconds. The list [funs] has the structure: [[(name1, f1, x1);
+ (name2, f2, x2); ...]], where [name1] is the name to label the
+ first test, [f1] is the function to run, and [x1] is its
+ input,... If [~style] is not [Nil], then the results are
+ printed. Returns the resulting list which can be passed to
+ {!Benchmark.tabulate} if you want a comparison table.
+
+ REMARK that [t] is the running time of the functions, not of the
+ repetition loop. Thus a very fast running function will need
+ lots of repetitions to make a difference of [t] seconds to the
+ empty loop. In this case, the running time of the loop will
+ dominate the whole process which can therefore take much longer
+ than [t] seconds. If you are only interested in the {i
+ relative} times of fast functions and not in their real running
+ times, we recommend you wrap each of them in a loop.
+
+ @param min_count a warning will be printed if the number of runs is
+ less than [min_count]. This is a first defense against
+ meaningless results. (default: [4L])
+ @param style printing style (default: [Auto])
+ @param fwidth number of chars reserved for the numbers (default: [5])
+ @param fdigits number of fractional digits of the numbers (default: [2])
+
+ @param repeat number of times each function running time is measured.
+ The default is [1] to be compatible with the former
+ version of this library but it is highly recommended
+ to set it to a higher number to enable confidence
+ statistics to be performed by {!Benchmark.tabulate}.
+ *)
+
+val throughput1 :
+ ?min_count:Int64.t ->
+ ?style:style ->
+ ?fwidth:int ->
+ ?fdigits:int ->
+ ?repeat:int ->
+ int -> ?name:string -> ('a -> 'b) -> 'a -> samples
+ (** [Benchmark.throughput1 ?min_count ?style ?fwidth ?fdigits t ?name f x]
+ runs one function [f] with input [x] for at least [t] seconds, and
+ returns the result, which is also printed unless [~style] is
+ [Nil]. See {!Benchmark.throughputN} for more information. *)
+
+val latencyN :
+ ?min_cpu:float ->
+ ?style:style ->
+ ?fwidth:int ->
+ ?fdigits:int ->
+ ?repeat:int ->
+ Int64.t -> (string * ('a -> 'b) * 'a) list -> samples
+ (** [Benchmark.latencyN ?min_cpu ?style ?fwidth ?fdigits n funs]
+ runs each function in list [funs] for [n] iterations. [n] must be
+ at least 4. The list [funs] has the structure: [[(name1, f1, x1);
+ (name2, f2, x2); ...]], where [name1] is the name to label the
+ first test, [f1] is the function to run, and [x1] is its input,...
+ If style is not [Nil], then the results are printed. Returns the
+ results list, which can be passed to {!Benchmark.tabulate} if you
+ want to print a comparison table.
+
+ @raise Invalid_argument if [n < 4L].
+ @param min_cpu a warning will be printed if the total CPU time is
+ less than [min_cpu]. This is a first defense against
+ meaningless results (default: [0.4]).
+ @param style printing style (default: [Auto]).
+ @param fwidth number of chars reserved for the numbers (default: [5]).
+ @param fdigits number of fractional digits of the numbers (default: [2]).
+
+ @param repeat number of times each function running time is measured.
+ The default is [1] to be compatible with the former
+ version of this library but it is highly recommended
+ to set it to a higher number to enable confidence
+ statistics to be performed by {!Benchmark.tabulate}.
+ *)
+
+val latency1 :
+ ?min_cpu:float ->
+ ?style:style ->
+ ?fwidth:int ->
+ ?fdigits:int ->
+ ?repeat:int ->
+ Int64.t -> ?name:string -> ('a -> 'b) -> 'a -> samples
+ (** [Benchmark.latency1 ?min_cpu ?style ?fwidth ?fdigits n ?name f x]
+ runs the function [f] with input [x] for [n] iterations, and
+ returns the results, which are also printed unless [~style] is
+ [Nil]. See {!Benchmark.latencyN} for more information. *)
+
+
+val tabulate : ?no_parent:bool -> ?confidence:float -> samples -> unit
+ (** [Benchmark.tablulate results] prints a comparison table for a
+ list of [results] obtained by {!Benchmark.latencyN} or
+ {!Benchmark.throughputN} with each function compared to all the
+ others. The table is of the type
+
+{[ Rate name1 name2 ... OR s/iter name1 name2 ...
+ name1 #/s -- r12 name1 # -- r12
+ name2 #/s r21 -- name2 # r21 --
+ ... ... ]}
+
+ where name1, name2,... are the labels of the tests sorted from
+ slowest to fastest and rij says how much namei is faster (or
+ slower if < 0) than namej (technically it is equal to (ri - rj)
+ expressed in percents of rj where ri and rj are the rates of namei
+ and namej respectively).
+
+ If several results are associated to a given name, they are used
+ to compute a Student's statistic to check whether the rates are
+ significantly different. If ri and rj are not believed to be
+ different, rij will be printed between brackets.
+
+ @param no_parent if [true], only take in account the times of the
+ children (default: [false]).
+
+ @param confidence is used to determine the confidence interval for
+ the Student's test. (default: [0.95]). *)
+
diff --git a/benchmark.mllib b/benchmark.mllib
new file mode 100644
index 0000000..271912b
--- /dev/null
+++ b/benchmark.mllib
@@ -0,0 +1,4 @@
+# OASIS_START
+# DO NOT EDIT (digest: 74575b23d5305310e904f87eb02ff980)
+Benchmark
+# OASIS_STOP
diff --git a/examples/ar_ba.ml b/examples/ar_ba.ml
new file mode 100644
index 0000000..e992827
--- /dev/null
+++ b/examples/ar_ba.ml
@@ -0,0 +1,110 @@
+(* Compare bigarray and standard float array access times. *)
+
+open Bigarray
+
+let n = 10_000
+let m = 1000
+
+(* Bigarrays
+ ***********************************************************************)
+type vec = (float, float64_elt, c_layout) Array1.t
+
+let a = Array1.create float64 c_layout n
+let () = Array1.fill a 1.
+
+let ba (a: vec) =
+ let s = ref 0. in
+ for i = 0 to n-1 do s := !s +. a.{i} done
+
+let ba_u (a: vec) =
+ let s = ref 0. in
+ for i = 0 to n-1 do s := !s +. Array1.unsafe_get a i done
+
+let ba_cl () =
+ let s = ref 0. in
+ for i = 0 to n-1 do s := !s +. a.{i} done
+
+let ba_gen a =
+ let s = ref 0. in
+ for i = 0 to n-1 do s := !s +. a.{i} done
+
+let ba_alloc () =
+ let a = Array1.create float64 c_layout n in
+ Array1.fill a 1.;
+ let s = ref 0. in
+ for j = 1 to m do
+ for i = 0 to n-1 do s := !s +. a.{i} done
+ done
+
+let set_ba (a: vec) = for i = 0 to n-1 do a.{i} <- 1. done
+
+let set_ba_alloc () =
+ let a = Array1.create float64 c_layout n in
+ for j = 1 to m do
+ for i = 0 to n-1 do a.{i} <- 3. done
+ done
+
+(* Arrays
+ ***********************************************************************)
+let b = Array.make n 1.
+
+let arr (b: float array) =
+ let s = ref 0. in
+ for i = 0 to n-1 do s := !s +. b.(i) done
+
+let arr_u (b: float array) =
+ let s = ref 0. in
+ for i = 0 to n - 1 do s := !s +. Array.unsafe_get b (i) done
+
+let arr_cl () =
+ let s = ref 0. in
+ for i = 0 to n-1 do s := !s +. b.(i) done
+
+let arr_alloc () =
+ let b = Array.make n 1. in
+ let s = ref 0. in
+ for j = 1 to m do
+ for i = 0 to n-1 do s := !s +. b.(i) done
+ done
+
+let set_arr (b: float array) = for i = 0 to n-1 do b.(i) <- 1. done
+
+let set_arr_alloc () =
+ let a = Array.create n 0. in
+ for j = 1 to m do
+ for i = 0 to n-1 do a.(i) <- 3. done
+ done
+
+(* Lists
+ ***********************************************************************)
+let c = Array.to_list b
+
+let list c = ignore(List.fold_left ( +. ) 0. c)
+
+
+open Benchmark
+
+let () =
+ let res = throughputN ~repeat:3 3
+ [("ba", (fun () -> ba a), ());
+ ("ba_u", (fun () -> ba_u a), ());
+ ("ba_cl", ba_cl, ());
+ ("ba_gen", (fun () -> ba_gen a), ());
+ ("set_ba", (fun () -> set_ba a), ());
+ ("arr", (fun () -> arr b), ());
+ ("arr_u", (fun () -> arr_u b), ());
+ ("arr_cl", arr_cl, ());
+ ("list", (fun () -> list c), ());
+ ("set_arr", (fun () -> set_arr b), ());
+ ] in
+ print_endline "Sum of elements or set all elements to 3.:";
+ tabulate res;
+
+ let res = throughputN ~repeat:3 3
+ [("ba", ba_alloc, ());
+ ("set_ba", set_ba_alloc, ());
+ ("arr", arr_alloc, ());
+ ("set_arr", set_arr_alloc, ());
+ ] in
+ print_endline "With allocation:";
+ tabulate res;
diff --git a/examples/composition.ml b/examples/composition.ml
new file mode 100644
index 0000000..bd1fdcd
--- /dev/null
+++ b/examples/composition.ml
@@ -0,0 +1,49 @@
+(* Tries to show the profile cost of composing small functions. *)
+
+(* Small functions: permutations of [0 .. n-1] *)
+
+let n = 100000
+let rotate r = fun k -> (k + r) mod n
+let reverse i j = fun k -> if i <= k && k <= j then j + i - k else k
+let splice l i j = fun k ->
+ if k < j then if k < i then k else k + l + 1
+ else if k <= j + l then k - j + i
+ else let k' = k - l - 1 in if k' < i then k' else k
+
+
+open Benchmark
+open Printf
+
+let ncomp = 400 (* Number of compositions *)
+
+let make_perms =
+ (* Create a random list of transformations *)
+ Random.self_init();
+ let rec random_perm ((p_f, p_v) as acc) i =
+ if i <= 0 then acc else
+ let c = Random.int 3 in
+ (* New function *)
+ let p =
+ if c = 0 then rotate (Random.int n)
+ else if c = 1 then reverse (Random.int n) (Random.int n)
+ else (* c = 2 *) splice (Random.int n) (Random.int n) (Random.int n) in
+ (* Corresponding array transformer *)
+ let p_vec w v =
+ for i = 0 to Array.length v - 1 do w.(i) <- p v.(i) done in
+ random_perm (p :: p_f, p_vec :: p_v) (i - 1) in
+ random_perm ([], [])
+
+let () =
+ let ncomp = 300 in
+ let p_f, p_v = make_perms ncomp in
+ let v = Array.init n (fun k -> k) in
+ let do_f () =
+ let f = List.fold_left (fun f f0 -> (fun k -> f0(f k))) (fun k -> k) p_f in
+ Array.map f v
+ and do_v () =
+ snd(List.fold_left (fun (w,v) f -> f w v; (v,w)) (Array.make n 0, v) p_v)
+ in
+
+ let res = throughputN ~repeat:3 5 [("fun", do_f, ());
+ ("vec", do_v, ()) ] in
+ tabulate res
diff --git a/examples/func_record.ml b/examples/func_record.ml
new file mode 100644
index 0000000..11c1ab3
--- /dev/null
+++ b/examples/func_record.ml
@@ -0,0 +1,39 @@
+module F(E : sig
+ val f : float -> float
+ val g : float -> float
+end) =
+struct
+ let h x = 1. +. E.f x +. E.g x
+end
+
+module A = F(struct let f x = x +. 1. let g x = 2. *. x end)
+
+
+type env = { f : float -> float; g : float -> float }
+
+let h_rec e x = 1. +. e.f x +. e.g x
+
+
+let h_fun f g x = 1. +. f x +. g x
+
+let f x = x +. 1.
+let g x = 2. *. x
+
+let h x = 1. +. f x +. g x
+
+
+open Benchmark
+
+let () =
+ let res = throughputN ~repeat:3 3
+ [("functor", (fun () -> A.h 1.), ());
+ ("record", (fun () -> h_rec { f = f; g = g } 1.), ());
+ ("fun arg", (fun () -> h_fun f g 1.), ());
+ ("no arg", (fun () -> h 1.), ());
+ ] in
+ print_endline "Functor vesus records vesus passing as arg:";
+ tabulate res
+
+(* Local Variables: *)
+(* compile-command: "make -k -C .." *)
+(* End: *)
diff --git a/examples/iter.ml b/examples/iter.ml
new file mode 100644
index 0000000..769671c
--- /dev/null
+++ b/examples/iter.ml
@@ -0,0 +1,45 @@
+open Bigarray
+
+let n = 1_000
+
+(* Bigarrays *)
+type vec = (float, float64_elt, c_layout) Array1.t
+let a = Array1.create float64 c_layout n
+let () = Array1.fill a 1.
+
+let ba f (x: vec) =
+ for i = 0 to n - 1 do f x.{i} done
+
+let ba_unsafe f (x: vec) =
+ for i = 0 to n - 1 do f (Array1.unsafe_get x i) done
+
+(* Arrays *)
+let b = Array.make n 1.
+
+let arr f (x: float array) =
+ for i = 0 to n-1 do f x.(i) done
+
+let arr_unsafe f (x: float array) =
+ for i = 0 to n-1 do f (Array.unsafe_get x i) done
+
+(* Lists *)
+let c = Array.to_list b
+
+
+open Benchmark
+
+
+let () =
+ (* Simulate a simple side effect *)
+ let z = ref 0. in
+ let f x = z := x in
+
+ let res = throughputN ~repeat:3 3
+ [("ba", (fun () -> ba f a), ());
+ ("ba_unsafe", (fun () -> ba_unsafe f a), ());
+ ("arr", (fun () -> arr f b), ());
+ ("arr_unsafe", (fun () -> arr_unsafe f b), ());
+ ("list", (fun () -> List.iter f c), ())
+ ] in
+ print_endline "Iterating a function with a simple side effect:";
+ tabulate res
diff --git a/examples/let_try.ml b/examples/let_try.ml
new file mode 100644
index 0000000..11100d9
--- /dev/null
+++ b/examples/let_try.ml
@@ -0,0 +1,30 @@
+(* Compare two possible implementations of let try x = ... with ... *)
+
+let k x = if x >= 0 then x else failwith "x < 0"
+
+let f a =
+ let sgn s x =
+ let y = (try Some(k x) with _ -> None) in
+ match y with
+ | None -> s
+ | Some y -> s + y in
+ ignore(Array.fold_left sgn 0 a)
+
+let g a =
+ let sgn s x =
+ (try
+ let y = k x in
+ (fun () -> s + y)
+ with _ ->
+ (fun () -> s)
+ )() in
+ ignore(Array.fold_left sgn 0 a)
+
+
+open Benchmark
+
+let () =
+ let a = Array.init 1000 (fun i -> Random.int 2 - 1) in
+ let res = throughputN ~repeat:5 1 [("Some", f, a);
+ ("()->", g, a); ] in
+ tabulate res
diff --git a/examples/loops.ml b/examples/loops.ml
new file mode 100644
index 0000000..c0710e7
--- /dev/null
+++ b/examples/loops.ml
@@ -0,0 +1,34 @@
+open Benchmark
+
+(* Test for the speed of recusion w.r.t. imperative loops to access
+ arrays fo floats. *)
+
+let rec_loop (a : float array) =
+ let rec loop i =
+ if i < Array.length a then begin
+ a.(i) <- a.(i) +. 1.;
+ loop (i + 1)
+ end in
+ loop 0
+
+let rec_loop2 (a : float array) =
+ let len = Array.length a in
+ let rec loop i =
+ if i < len then begin
+ a.(i) <- a.(i) +. 1.;
+ loop (i + 1)
+ end in
+ loop 0
+
+let for_loop (a : float array) =
+ for i = 0 to Array.length a - 1 do
+ a.(i) <- a.(i) +. 1.
+ done
+
+let () =
+ let a = Array.make 100 1. in
+ let res = throughputN ~repeat:5 1
+ [("rec", rec_loop, a);
+ ("rec2", rec_loop2, a);
+ ("for", for_loop, a); ] in
+ tabulate res
diff --git a/examples/match_array.ml b/examples/match_array.ml
new file mode 100644
index 0000000..e13a7b4
--- /dev/null
+++ b/examples/match_array.ml
@@ -0,0 +1,40 @@
+(* This is a typical problem where the functions are so fast (on a
+ 2Ghz machine) that it takes way too long to get results. Thus a
+ wrapping in a loop is done. *)
+
+let n = 100
+
+let string_of_month1 =
+ let month = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun"; "Jul"; "Aug";
+ "Sep"; "Oct"; "Nov"; "Dec" |] in
+ fun i -> Array.unsafe_get month i
+
+let f1 () =
+ for i = 1 to n do ignore(string_of_month1 7) done
+
+let string_of_month2 = function
+ | 0 -> "Jan"
+ | 1 -> "Feb"
+ | 2 -> "Mar"
+ | 3 -> "Apr"
+ | 4 -> "May"
+ | 5 -> "Jun"
+ | 6 -> "Jul"
+ | 7 -> "Aug"
+ | 8 -> "Sep"
+ | 9 -> "Oct"
+ | 10 -> "Nov"
+ | 11 -> "Dec"
+ | _ -> failwith "h"
+
+let f2 () =
+ for i = 1 to n do ignore(string_of_month2 7) done
+
+
+open Benchmark
+
+let () =
+ let res = throughputN 3 ~repeat:5 [ ("arr", f1, ());
+ ("pat", f2, ()); ] in
+ tabulate res
+
diff --git a/examples/numbers.ml b/examples/numbers.ml
new file mode 100644
index 0000000..38d22b9
--- /dev/null
+++ b/examples/numbers.ml
@@ -0,0 +1,51 @@
+open Printf
+open Benchmark
+
+(* Test the speed of addition for native ints (unboxed), and
+ Int32/Int64 (which are both boxed).
+
+ The output looks something like numbers.out
+*)
+
+let f_int n =
+ let rec loop i sum =
+ if i < n then loop (i + 1) (sum + 1) else sum in
+ loop 0 0
+
+let f_int32 n =
+ let rec loop i sum =
+ if i < n then loop (i + 1) (Int32.add sum Int32.one) else sum in
+ Int32.to_int (loop 0 Int32.zero)
+
+let f_int64 n =
+ let rec loop i sum =
+ if i < n then loop (i + 1) (Int64.add sum Int64.one) else sum in
+ Int64.to_int (loop 0 Int64.zero)
+
+let () =
+ (* print out the results of the f_* functions to doublecheck that
+ they work as we intend. *)
+ printf "f_int 666 = %d\n" (f_int 666);
+ printf "f_int32 666 = %d\n" (f_int32 666);
+ printf "f_int64 666 = %d\n" (f_int64 666);
+ print_newline ();
+
+ (* let's exercise the *1 functions: *)
+ let _ = latency1 ~name:"int-1-lat" 1000L f_int 10000 in
+ let _ = throughput1 ~name:"int-1-thru" 5 f_int 10000 in
+ print_newline ();
+
+ (* now let's exercise the *N functions: *)
+ let res = throughputN ~repeat:5 10
+ [("int", f_int, 10000);
+ ("int32", f_int32, 10000);
+ ("int64", f_int64, 10000); ] in
+ print_newline ();
+ tabulate res;
+
+ print_newline ();
+ let res = latencyN 2000L [("int", f_int, 10000);
+ ("int32", f_int32, 10000);
+ ("int64", f_int64, 10000); ] in
+ print_newline ();
+ tabulate res
diff --git a/examples/regexps.ml b/examples/regexps.ml
new file mode 100644
index 0000000..8773daf
--- /dev/null
+++ b/examples/regexps.ml
@@ -0,0 +1,49 @@
+open Printf
+open Benchmark
+
+(* Test the speed of standard regular expressions vs. Pcre using a
+ simple regexp with captures.
+
+ The output looks something like regexps.out
+*)
+
+(* Create a chunk of data to search.
+ It's full of "near hits", strings of "012345678"
+ with a string on the end we are searching for: "0123456789" *)
+let bigdata =
+ let size = 500000 in
+ let buf = Buffer.create size in
+ for i = 1 to size/10 - 1 do Buffer.add_string buf "012345678 " done;
+ Buffer.add_string buf "0123456789";
+ Buffer.contents buf
+
+let pcre_re = Pcre.regexp "(012345678) (0123456789)"
+let str_re = Str.regexp "\\(012345678\\) \\(0123456789\\)"
+
+let pcre_match dat =
+ let group = Pcre.extract ~rex:pcre_re dat in
+ (group.(1), group.(2))
+
+let str_match dat =
+ let _pos = Str.search_forward str_re dat 0 in
+ (Str.matched_group 1 dat, Str.matched_group 2 dat)
+
+let () =
+ (* Print out the results of the functions to doublecheck that they
+ work as we intend. *)
+ let (a, b) = pcre_match bigdata in printf "Pcre matches: %s %s\n" a b;
+ let (a, b) = str_match bigdata in printf "Str matches: %s %s\n" a b;
+ print_newline ();
+
+ let res = throughputN ~repeat:5 5
+ [("pcre match", pcre_match, bigdata);
+ ("str match", str_match, bigdata)] in
+ print_newline();
+ tabulate res
+
+(* print_newline(); *)
+(* let res = latencyN ~repeat:5 100 *)
+(* [("pcre match", pcre_match, bigdata); *)
+(* ("str match", str_match, bigdata)] in *)
+(* print_newline(); *)
+(* tabulate res *)
diff --git a/examples/try_if.ml b/examples/try_if.ml
new file mode 100644
index 0000000..5ea18b3
--- /dev/null
+++ b/examples/try_if.ml
@@ -0,0 +1,34 @@
+open Bigarray
+
+let n = 100
+
+let a = Array1.create float64 fortran_layout n
+
+(* Base case: no test *)
+let f0 () =
+ for i = 1 to n do
+ let x = a.{i} in
+ ignore(x)
+ done;
+ ignore(0.)
+
+let f1 () =
+ for i = 1 to n+1 do
+ let x = try a.{i} with _ -> 0. in
+ ignore(x)
+ done
+
+let f2 () =
+ for i = 1 to n+1 do
+ let x = if i <= n then a.{i} else 0. in
+ ignore(x)
+ done
+
+open Benchmark
+
+let () =
+ let res = throughputN ~repeat:5 3 [("no test", f0, ());
+ ("try", f1, ());
+ ("if", f2, ()) ] in
+ print_endline "Bigarray bound checking:";
+ tabulate res
diff --git a/myocamlbuild.ml b/myocamlbuild.ml
new file mode 100644
index 0000000..a646114
--- /dev/null
+++ b/myocamlbuild.ml
@@ -0,0 +1,491 @@
+(* OASIS_START *)
+(* DO NOT EDIT (digest: 5eab8ed07dfb4303dc64c4c33706fe5e) *)
+module OASISGettext = struct
+(* # 21 "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 OASISExpr = struct
+(* # 21 "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
+
+
+# 117 "myocamlbuild.ml"
+module BaseEnvLight = struct
+(* # 21 "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 var_get name env =
+ let rec var_expand str =
+ let buff =
+ Buffer.create ((String.length str) * 2)
+ in
+ Buffer.add_substitute
+ buff
+ (fun var ->
+ try
+ var_expand (MapString.find var env)
+ with Not_found ->
+ failwith
+ (Printf.sprintf
+ "No variable %s defined when trying to expand %S."
+ var
+ str))
+ str;
+ Buffer.contents buff
+ in
+ var_expand (MapString.find name env)
+
+ let var_choose lst env =
+ OASISExpr.choose
+ (fun nm -> var_get nm env)
+ lst
+end
+
+
+# 215 "myocamlbuild.ml"
+module MyOCamlbuildFindlib = struct
+(* # 21 "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
+
+ (* 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 split s ch =
+ let x =
+ ref []
+ in
+ let rec go s =
+ let pos =
+ String.index s ch
+ in
+ x := (String.before s pos)::!x;
+ go (String.after s (pos + 1))
+ in
+ try
+ go s
+ with Not_found -> !x
+
+ let split_nl s = split s '\n'
+
+ let before_space s =
+ try
+ String.before s (String.index s ' ')
+ with Not_found -> s
+
+ (* this lists all supported packages *)
+ let find_packages () =
+ List.map before_space (split_nl & run_and_read "ocamlfind list")
+
+ (* this is supposed to list available syntaxes, but I don't know how to do it. *)
+ let find_syntaxes () = ["camlp4o"; "camlp4r"]
+
+ (* ocamlfind command *)
+ let ocamlfind x = S[A"ocamlfind"; x]
+
+ let dispatch =
+ function
+ | Before_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"
+
+ | After_rules ->
+
+ (* When one link an OCaml library/binary/package, one should use -linkpkg *)
+ flag ["ocaml"; "link"; "program"] & A"-linkpkg";
+
+ (* For each ocamlfind package one inject the -package option when
+ * compiling, computing dependencies, generating documentation and
+ * linking. *)
+ List.iter
+ begin fun pkg ->
+ flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg];
+ end
+ (find_packages ());
+
+ (* 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"])
+
+ | _ ->
+ ()
+
+end
+
+module MyOCamlbuildBase = struct
+(* # 21 "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
+
+(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *)
+
+ type t =
+ {
+ lib_ocaml: (name * dir 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" 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, [] ->
+ ocaml_lib nm
+ | nm, dir :: tl ->
+ 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)
+ 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.
+ *)
+ dep ["link"; "ocaml"; "program"; tag_libstubs lib]
+ [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)];
+
+ dep ["compile"; "ocaml"; "program"; 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
+ flag tags & spec)
+ t.flags
+ | _ ->
+ ()
+
+ let dispatch_default t =
+ dispatch_combine
+ [
+ dispatch t;
+ MyOCamlbuildFindlib.dispatch;
+ ]
+
+end
+
+
+# 476 "myocamlbuild.ml"
+open Ocamlbuild_plugin;;
+let package_default =
+ {
+ MyOCamlbuildBase.lib_ocaml = [("benchmark", [])];
+ lib_c = [];
+ flags = [];
+ includes = [];
+ }
+ ;;
+
+let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;;
+
+# 490 "myocamlbuild.ml"
+(* OASIS_STOP *)
+Ocamlbuild_plugin.dispatch dispatch_default;;
diff --git a/setup.ml b/setup.ml
new file mode 100644
index 0000000..e18726f
--- /dev/null
+++ b/setup.ml
@@ -0,0 +1,6066 @@
+let () =
+ try Topdirs.dir_directory (Sys.getenv "OCAML_TOPLEVEL_PATH")
+ with Not_found -> ();;
+
+(* OASIS_START *)
+(* DO NOT EDIT (digest: 1cc62ef077a105a2b3cdd44d970685cc) *)
+(*
+ Regenerated by OASIS v0.3.0
+ Visit http://oasis.forge.ocamlcore.org for more information and
+ documentation about functions used in this file.
+*)
+module OASISGettext = struct
+(* # 21 "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
+(* # 21 "src/oasis/OASISContext.ml" *)
+
+ open OASISGettext
+
+ type level =
+ [ `Debug
+ | `Info
+ | `Warning
+ | `Error]
+
+ type t =
+ {
+ 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 args () =
+ ["-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")]
+end
+
+module OASISString = struct
+(* # 1 "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 = String.make (String.length s) 'X' in
+ for i = 0 to String.length s - 1 do
+ buf.[i] <- f s.[i]
+ done;
+ buf
+
+end
+
+module OASISUtils = struct
+(* # 21 "src/oasis/OASISUtils.ml" *)
+
+ open OASISGettext
+
+ module MapString = Map.Make(String)
+
+ let map_string_of_assoc assoc =
+ List.fold_left
+ (fun acc (k, v) -> MapString.add k v acc)
+ MapString.empty
+ assoc
+
+ module SetString = Set.Make(String)
+
+ let set_string_add_list st lst =
+ List.fold_left
+ (fun acc e -> SetString.add e acc)
+ st
+ lst
+
+ let set_string_of_list =
+ set_string_add_list
+ SetString.empty
+
+
+ let compare_csl s1 s2 =
+ String.compare (String.lowercase s1) (String.lowercase s2)
+
+ module HashStringCsl =
+ Hashtbl.Make
+ (struct
+ type t = string
+
+ let equal s1 s2 =
+ (String.lowercase s1) = (String.lowercase s2)
+
+ let hash s =
+ Hashtbl.hash (String.lowercase s)
+ 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
+ String.lowercase 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
+(* # 21 "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
+
+(* # 71 "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
+ String.lowercase
+ 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
+(* # 21 "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
+(* # 21 "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 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 version_0_3_or_after t =
+ comparator_apply t (VGreaterEqual (string_of_version "0.3"))
+
+end
+
+module OASISLicense = struct
+(* # 21 "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
+(* # 21 "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 OASISTypes = struct
+(* # 21 "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
+
+(* # 102 "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 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
+ | 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 | `Executable | `Flag | `SrcRepo | `Test | `Doc ]
+
+ type package =
+ {
+ oasis_version: OASISVersion.t;
+ ocaml_version: OASISVersion.comparator option;
+ findlib_version: OASISVersion.comparator option;
+ 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: string 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;
+ schema_data: PropList.Data.t;
+ plugin_data: plugin_data;
+ }
+
+end
+
+module OASISUnixPath = struct
+(* # 21 "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 (String.capitalize base)
+
+ let uncapitalize_file f =
+ let dir = dirname f in
+ let base = basename f in
+ concat dir (String.uncapitalize base)
+
+end
+
+module OASISHostPath = struct
+(* # 21 "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
+(* # 21 "src/oasis/OASISSection.ml" *)
+
+ open OASISTypes
+
+ let section_kind_common =
+ function
+ | Library (cs, _, _) ->
+ `Library, 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)
+ | 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"
+ | `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
+(* # 21 "src/oasis/OASISBuildSection.ml" *)
+
+end
+
+module OASISExecutable = struct
+(* # 21 "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
+(* # 21 "src/oasis/OASISLibrary.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 *
+ group_t list)
+
+ (* Look for a module file, considering capitalization or not. *)
+ let find_module source_file_exists (cs, bs, lib) 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 (cs, bs, lib) 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 (cs, bs, lib) modul with
+ | `Sources (base_fn, _) ->
+ [base_fn]
+ | `No_sources lst ->
+ OASISMessage.warning
+ ~ctxt
+ (f_ "Cannot find source file matching \
+ module '%s' in library %s")
+ modul cs.cs_name;
+ lst
+ in
+ List.map
+ (fun nm ->
+ List.map
+ (fun base_fn -> base_fn ^"."^ext)
+ (find_module nm))
+ lst
+ in
+
+ (* The headers that should be compiled along *)
+ let headers =
+ if lib.lib_pack then
+ []
+ else
+ find_modules
+ lib.lib_modules
+ "cmi"
+ in
+
+ (* The .cmx that be compiled along *)
+ let cmxs =
+ let should_be_built =
+ (not lib.lib_pack) && (* Do not install .cmx packed submodules *)
+ match bs.bs_compiled_object with
+ | Native -> true
+ | Best -> is_native
+ | Byte -> false
+ in
+ if should_be_built then
+ find_modules
+ (lib.lib_modules @ lib.lib_internal_modules)
+ "cmx"
+ else
+ []
+ in
+
+ let acc_nopath =
+ []
+ 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"] :: 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)
+
+ type data = common_section * build_section * library
+ 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
+
+ | 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, lib) mp
+ | _ ->
+ mp)
+ MapString.empty
+ pkg.sections
+ in
+
+ let groups =
+ group_of_tree group_mp
+ in
+
+ let library_name_of_findlib_name =
+ Lazy.lazy_from_fun
+ (fun () ->
+ (* Revert findlib_name_of_library_name. *)
+ MapString.fold
+ (fun k v mp -> MapString.add v k mp)
+ fndlb_name_of_lib_name
+ MapString.empty)
+ 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
+(* # 21 "src/oasis/OASISFlag.ml" *)
+
+end
+
+module OASISPackage = struct
+(* # 21 "src/oasis/OASISPackage.ml" *)
+
+end
+
+module OASISSourceRepository = struct
+(* # 21 "src/oasis/OASISSourceRepository.ml" *)
+
+end
+
+module OASISTest = struct
+(* # 21 "src/oasis/OASISTest.ml" *)
+
+end
+
+module OASISDocument = struct
+(* # 21 "src/oasis/OASISDocument.ml" *)
+
+end
+
+module OASISExec = struct
+(* # 21 "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
+(* # 21 "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
+ (if case_sensitive then
+ file_exists_case
+ else
+ Sys.file_exists)
+ 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
+
+ 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
+
+
+# 2142 "setup.ml"
+module BaseEnvLight = struct
+(* # 21 "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 var_get name env =
+ let rec var_expand str =
+ let buff =
+ Buffer.create ((String.length str) * 2)
+ in
+ Buffer.add_substitute
+ buff
+ (fun var ->
+ try
+ var_expand (MapString.find var env)
+ with Not_found ->
+ failwith
+ (Printf.sprintf
+ "No variable %s defined when trying to expand %S."
+ var
+ str))
+ str;
+ Buffer.contents buff
+ in
+ var_expand (MapString.find name env)
+
+ let var_choose lst env =
+ OASISExpr.choose
+ (fun nm -> var_get nm env)
+ lst
+end
+
+
+# 2240 "setup.ml"
+module BaseContext = struct
+(* # 21 "src/base/BaseContext.ml" *)
+
+ open OASISContext
+
+ let args = args
+
+ let default = default
+
+end
+
+module BaseMessage = struct
+(* # 21 "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
+(* # 21 "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
+(* # 21 "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
+(* # 21 "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
+(* # 21 "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
+(* # 21 "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" -> ".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
+(* # 21 "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
+(* # 21 "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
+(* # 21 "src/base/BaseBuilt.ml" *)
+
+ open OASISTypes
+ open OASISGettext
+ open BaseStandardVar
+ open BaseMessage
+
+ type t =
+ | BExec (* Executable *)
+ | BExecLib (* Library coming with executable *)
+ | BLib (* Library *)
+ | BDoc (* Document *)
+
+ let to_log_event_file t nm =
+ "built_"^
+ (match t with
+ | BExec -> "exec"
+ | BExecLib -> "exec_lib"
+ | BLib -> "lib"
+ | 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")
+ | 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
+
+end
+
+module BaseCustom = struct
+(* # 21 "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
+(* # 21 "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 _ | Flag _ | Test _ | SrcRepo _ | Doc _ ->
+ ())
+ pkg.sections
+end
+
+module BaseTest = struct
+(* # 21 "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 OASISVersion.version_0_3_or_after pkg.oasis_version &&
+ 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
+(* # 21 "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 OASISVersion.version_0_3_or_after pkg.oasis_version &&
+ 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
+(* # 21 "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
+ 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";
+ ]
+ (failwithf (f_ "Don't know what to do with '%s'"))
+ "";
+
+ info "Running configure step";
+ configure t [||];
+
+ 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 _
+ | 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 update_setup_ml t =
+ let oasis_fn =
+ match t.oasis_fn with
+ | Some fn -> fn
+ | None -> "_oasis"
+ 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 "_oasis" 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
+
+
+# 4480 "setup.ml"
+module InternalConfigurePlugin = struct
+(* # 21 "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;
+
+ (* 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
+(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *)
+
+ (** Install using internal scheme
+ @author Sylvain Le Gall
+ *)
+
+ open BaseEnv
+ open BaseStandardVar
+ open BaseMessage
+ open OASISTypes
+ open OASISLibrary
+ 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 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
+
+ (** 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
+ (fun acc modul ->
+ try
+ List.find
+ OASISFileUtil.file_exists_case
+ (List.map
+ (Filename.concat path)
+ [modul^".mli";
+ modul^".ml";
+ String.uncapitalize modul^".mli";
+ String.capitalize modul^".mli";
+ String.uncapitalize modul^".ml";
+ String.capitalize modul^".ml"])
+ :: acc
+ with Not_found ->
+ begin
+ warning
+ (f_ "Cannot find source header for module %s \
+ in library %s")
+ modul cs.cs_name;
+ 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
+ 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, lib, children) ->
+ files_of_library data_and_files (cs, bs, lib), 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
+
+
+# 5233 "setup.ml"
+module OCamlbuildCommon = struct
+(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *)
+
+ (** Functions common to OCamlbuild build and doc plugin
+ *)
+
+ open OASISGettext
+ open BaseEnv
+ open BaseStandardVar
+
+ 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 (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
+(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *)
+
+ (** Build using ocamlbuild
+ @author Sylvain Le Gall
+ *)
+
+ open OASISTypes
+ open OASISGettext
+ open OASISUtils
+ open BaseEnv
+ open OCamlbuildCommon
+ open BaseStandardVar
+ open BaseMessage
+
+ let cond_targets_hook =
+ ref (fun lst -> lst)
+
+ let build 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 ends_with nd fn =
+ let nd_len =
+ String.length nd
+ in
+ (String.length fn >= nd_len)
+ &&
+ (String.sub
+ fn
+ (String.length fn - nd_len)
+ nd_len) = nd
+ in
+
+ let tgts =
+ List.flatten
+ (List.filter
+ (fun l -> l <> [])
+ (List.map
+ (List.filter
+ (fun fn ->
+ ends_with ".cma" fn
+ || ends_with ".cmxs" fn
+ || ends_with ".cmxa" fn
+ || ends_with (ext_lib ()) fn
+ || ends_with (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
+
+ | 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 _ | 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
+ (f_ "No one of expected built files %s exists")
+ (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns)))
+ lst;
+ (BaseBuilt.register bt bnm lst)
+ in
+
+ let cond_targets =
+ (* Run the hook *)
+ !cond_targets_hook cond_targets
+ in
+
+ (* Run a list of target... *)
+ run_ocamlbuild
+ (List.flatten
+ (List.map snd cond_targets))
+ 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
+(* # 21 "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
+
+
+
+ let doc_build path pkg (cs, doc) argv =
+ let index_html =
+ OASISUnixPath.make
+ [
+ path;
+ cs.cs_name^".docdir";
+ "index.html";
+ ]
+ in
+ let tgt_dir =
+ OASISHostPath.make
+ [
+ build_dir argv;
+ OASISHostPath.of_unix path;
+ cs.cs_name^".docdir";
+ ]
+ in
+ run_ocamlbuild [index_html] 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 t pkg (cs, doc) argv =
+ run_clean argv;
+ BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name
+
+end
+
+
+# 5558 "setup.ml"
+open OASISTypes;;
+
+let setup_t =
+ {
+ BaseSetup.configure = InternalConfigurePlugin.configure;
+ build = OCamlbuildPlugin.build;
+ test = [];
+ doc = [("API", OCamlbuildDocPlugin.doc_build ".")];
+ install = InternalInstallPlugin.install;
+ uninstall = InternalInstallPlugin.uninstall;
+ clean = [OCamlbuildPlugin.clean];
+ clean_test = [];
+ clean_doc = [("API", OCamlbuildDocPlugin.doc_clean ".")];
+ distclean = [];
+ distclean_test = [];
+ distclean_doc = [];
+ package =
+ {
+ oasis_version = "0.3";
+ ocaml_version = None;
+ findlib_version = None;
+ name = "benchmark";
+ version = "1.3";
+ license =
+ OASISLicense.DEP5License
+ (OASISLicense.DEP5Unit
+ {
+ OASISLicense.license = "LGPL";
+ excption = Some "OCaml linking";
+ version = OASISLicense.Version "3.0";
+ });
+ license_file = None;
+ copyrights = [];
+ maintainers = [];
+ authors =
+ ["Christophe Troestler <Christophe.Troestler@umons.ac.be>"];
+ homepage = Some "http://ocaml-benchmark.forge.ocamlcore.org/";
+ synopsis = "Benchmark running times of code.";
+ description =
+ Some
+ "This module provides a set of tools to measure the running times\nof your functions and to easily compare the results. A statistical\ntest is used to determine whether the results truly differ.";
+ categories = [];
+ conf_type = (`Configure, "internal", Some "0.3");
+ conf_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)];
+ };
+ build_type = (`Build, "ocamlbuild", Some "0.3");
+ build_custom =
+ {
+ pre_command = [(OASISExpr.EBool true, None)];
+ post_command = [(OASISExpr.EBool true, None)];
+ };
+ install_type = (`Install, "internal", Some "0.3");
+ 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 =
+ [
+ Flag
+ ({
+ cs_name = "examples";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ flag_description =
+ Some "Whether to compile the examples.";
+ flag_default = [(OASISExpr.EBool true, false)];
+ });
+ Library
+ ({
+ cs_name = "benchmark";
+ 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 = Best;
+ bs_build_depends = [FindlibPackage ("unix", 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, [])];
+ },
+ {
+ lib_modules = ["Benchmark"];
+ lib_pack = false;
+ lib_internal_modules = [];
+ lib_findlib_parent = None;
+ lib_findlib_name = None;
+ lib_findlib_containers = [];
+ });
+ Doc
+ ({
+ cs_name = "API";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ doc_type = (`Doc, "OCamlbuild", Some "0.3");
+ 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/api";
+ doc_title = "API reference for Benchmark";
+ doc_authors = [];
+ doc_abstract = None;
+ doc_format = OtherDoc;
+ doc_data_files = [];
+ doc_build_tools =
+ [ExternalTool "ocamldoc"; ExternalTool "ocamlbuild"];
+ });
+ Executable
+ ({
+ cs_name = "ar_ba";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends =
+ [
+ InternalLibrary "benchmark";
+ FindlibPackage ("bigarray", 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 = "ar_ba.ml"; });
+ Executable
+ ({
+ cs_name = "composition";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends = [InternalLibrary "benchmark"];
+ 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 = "composition.ml"; });
+ Executable
+ ({
+ cs_name = "iter";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends =
+ [
+ InternalLibrary "benchmark";
+ FindlibPackage ("bigarray", 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 = "iter.ml"; });
+ Executable
+ ({
+ cs_name = "let_try";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends =
+ [
+ InternalLibrary "benchmark";
+ FindlibPackage ("bigarray", 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 = "let_try.ml"; });
+ Executable
+ ({
+ cs_name = "loops";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends = [InternalLibrary "benchmark"];
+ 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 = "loops.ml"; });
+ Executable
+ ({
+ cs_name = "match_array";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends = [InternalLibrary "benchmark"];
+ 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 = "match_array.ml"; });
+ Executable
+ ({
+ cs_name = "numbers";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends = [InternalLibrary "benchmark"];
+ 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 = "numbers.ml"; });
+ Executable
+ ({
+ cs_name = "regexps";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends =
+ [
+ InternalLibrary "benchmark";
+ FindlibPackage ("str", None);
+ FindlibPackage ("pcre", 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 = "regexps.ml"; });
+ Executable
+ ({
+ cs_name = "try_if";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends =
+ [
+ InternalLibrary "benchmark";
+ FindlibPackage ("bigarray", 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 = "try_if.ml"; });
+ Executable
+ ({
+ cs_name = "func_record";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "examples", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "examples/";
+ bs_compiled_object = Best;
+ bs_build_depends = [InternalLibrary "benchmark"];
+ 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 = "func_record.ml"; });
+ Executable
+ ({
+ cs_name = "long_run";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ bs_build =
+ [
+ (OASISExpr.EBool true, false);
+ (OASISExpr.EFlag "tests", true)
+ ];
+ bs_install = [(OASISExpr.EBool true, false)];
+ bs_path = "tests";
+ bs_compiled_object = Best;
+ bs_build_depends =
+ [
+ InternalLibrary "benchmark";
+ FindlibPackage ("unix", 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 = "long_run.ml"; });
+ SrcRepo
+ ({
+ cs_name = "trunk";
+ cs_data = PropList.Data.create ();
+ cs_plugin_data = [];
+ },
+ {
+ src_repo_type = Svn;
+ src_repo_location =
+ "svn://scm.ocamlcore.org/svn/ocaml-benchmark/trunk";
+ src_repo_browser =
+ Some
+ "https://forge.ocamlcore.org/scm/browser.php?group_id=197";
+ src_repo_module = None;
+ src_repo_branch = None;
+ src_repo_tag = None;
+ src_repo_subdir = None;
+ })
+ ];
+ plugins = [(`Extra, "META", Some "0.2")];
+ schema_data = PropList.Data.create ();
+ plugin_data = [];
+ };
+ oasis_fn = Some "_oasis";
+ oasis_version = "0.3.0";
+ oasis_digest =
+ Some "\175\132\143\187\165\140\142\184\127(9\134{\018\211s";
+ oasis_exec = None;
+ oasis_setup_args = [];
+ setup_update = false;
+ };;
+
+let setup () = BaseSetup.setup setup_t;;
+
+# 6063 "setup.ml"
+(* OASIS_STOP *)
+let () = setup ();;
diff --git a/tests/long_run.ml b/tests/long_run.ml
new file mode 100644
index 0000000..db71d83
--- /dev/null
+++ b/tests/long_run.ml
@@ -0,0 +1,16 @@
+(* Test that the test is performed correctly even when the test
+ execution time exceeds the max throughput time. *)
+
+open Benchmark
+
+let long () =
+ let s = ref 0. in
+ for i = 1 to 100_000 do
+ for j = 1 to 2_000 do
+ s := !s +. 1.
+ done
+ done
+
+let () =
+ let t = throughputN 1 ["long", long, ()] in
+ tabulate t
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-11 15:05:27 +0000