├── VERSION ├── examples ├── euler │ ├── euler022.ml │ ├── dune │ ├── euler014.ml │ ├── Makefile │ ├── euler009.ml │ ├── euler010.ml │ ├── euler023.ml │ ├── euler001.ml │ ├── euler012.ml │ ├── euler024.ml │ ├── euler021.ml │ ├── euler018.ml │ ├── euler008.ml │ ├── euler019.ml │ ├── euler013.ml │ └── euler011.ml ├── tools │ ├── myocamlbuild.ml │ ├── _tags │ ├── browser.ml │ ├── shuffle.ml │ ├── shuffle2.ml │ ├── tools.itarget │ ├── cat.ml │ ├── mygzip.ml │ ├── gunzip.ml │ ├── conv.ml │ ├── cat2.ml │ └── pair.ml ├── snippets │ ├── myocamlbuild.ml │ ├── unicode.ml │ ├── unicode2.ml │ ├── _tags │ ├── snippets.itarget │ ├── netchan_cat.ml │ ├── ropes_vs_strings.ml │ ├── parallelsort.ml │ ├── accumulator.ml │ └── test_printf.ml ├── _tags ├── benchmark │ ├── _tags │ ├── run_tests.sh │ ├── t_pow.ml │ ├── t_read_stub.c │ ├── Makefile │ ├── t_strstr.ml │ └── t_read.log └── README ├── benchsuite ├── lib │ └── dune ├── array_filter.png ├── README ├── flip.ml ├── bench_num.ml ├── fsum.ml ├── bench_finger_tree_enum.ml ├── rand_choice.ml ├── mid.ml ├── grouping.ml ├── bench_int.ml ├── dynarray_iter.ml ├── array_filter.ml ├── bench_set_to_seq.ml ├── lazylist.ml ├── bitset.ml └── array_partition.ml ├── src ├── batChar.ml ├── batOpaqueInnerSys.ml ├── batConcreteQueue_402.mli ├── batConcreteQueue_403.mli ├── batteriesThread.ml ├── extlib.ml ├── batBytesCompat.ml ├── batInnerShuffle.ml ├── batPrintexc.ml ├── batUnit.ml ├── batLexing.ml ├── batInterfaces.ml ├── batReturn.ml ├── batGlobal.ml ├── batteriesConfig.mlp ├── batSys.ml ├── batAvlTree.mli ├── batUnit.mli ├── batConcreteQueue_403.ml ├── batScanf.ml ├── batMarshal.ml ├── batUref.mli ├── batGc.ml ├── batEither.ml ├── batMutex.ml ├── batBase64.mli ├── batConcreteQueue_402.ml ├── batMultiMap.ml ├── batStack.ml ├── dune ├── batGlobal.mli ├── batUChar.ml ├── batInnerPervasives.ml ├── batReturn.mli ├── batConcurrent.ml ├── batFilename.ml ├── batSplay.mli ├── batUChar.mli ├── batDigest.ml ├── batInterfaces.mli ├── batConcurrent.mli ├── batHashcons.mli └── batRMutex.mli ├── testsuite ├── dune ├── test_multipmap.ml ├── test_dynarray.ml ├── test_digest.ml ├── test_optparse.ml ├── main.ml ├── test_hashtbl.ml ├── test_stack.ml ├── test_base64.ml ├── test_hashcons.ml ├── test_unix.ml ├── test_vect.ml ├── test_mapfunctors.ml ├── test_mappable.ml ├── test_num.ml ├── test_print.ml ├── test_bounded.ml ├── test_pmap.ml ├── test_string.ml ├── test_random.ml ├── test_pervasives.ml └── test_toplevel.ml ├── dune-project ├── scripts ├── find_since.sh ├── install_deps.sh ├── replace_since.sh └── test_install.sh ├── test-build ├── test.ml └── Makefile ├── qtest ├── README.md └── qtest_preamble.ml ├── toplevel ├── dune ├── ocamlinit ├── batteriesHelp.mli └── battop.ml ├── .gitignore ├── README.folders ├── .travis.yml ├── .travis.sh ├── batteries_dev.el ├── batteries.opam ├── plot ├── .github └── workflows │ └── ci.yml ├── Makefile ├── .mailmap ├── FAQ └── check_raise /VERSION: -------------------------------------------------------------------------------- 1 | 3.10.0 2 | -------------------------------------------------------------------------------- /examples/euler/euler022.ml: -------------------------------------------------------------------------------- 1 | (* uses names.txt *) 2 | 3 | -------------------------------------------------------------------------------- /examples/tools/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | ../../build/myocamlbuild.ml -------------------------------------------------------------------------------- /examples/snippets/myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | ../../build/myocamlbuild.ml -------------------------------------------------------------------------------- /examples/tools/_tags: -------------------------------------------------------------------------------- 1 | not(<*_dyn*>): pkg_batteries,debug 2 | -------------------------------------------------------------------------------- /examples/_tags: -------------------------------------------------------------------------------- 1 | 2 | : pkg_netstring 3 | : thread 4 | 5 | -------------------------------------------------------------------------------- /benchsuite/lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bench) 3 | (libraries unix) 4 | (wrapped false) 5 | ) 6 | -------------------------------------------------------------------------------- /src/batChar.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-batteries-team/batteries-included/HEAD/src/batChar.ml -------------------------------------------------------------------------------- /src/batOpaqueInnerSys.ml: -------------------------------------------------------------------------------- 1 | (* this file must be compiled with -opaque *) 2 | let opaque_identity x = x 3 | -------------------------------------------------------------------------------- /testsuite/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name main) 3 | (flags (:standard -w -3)) 4 | (libraries batteries oUnit threads)) 5 | -------------------------------------------------------------------------------- /benchsuite/array_filter.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-batteries-team/batteries-included/HEAD/benchsuite/array_filter.png -------------------------------------------------------------------------------- /examples/snippets/unicode.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-batteries-team/batteries-included/HEAD/examples/snippets/unicode.ml -------------------------------------------------------------------------------- /examples/snippets/unicode2.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-batteries-team/batteries-included/HEAD/examples/snippets/unicode2.ml -------------------------------------------------------------------------------- /examples/snippets/_tags: -------------------------------------------------------------------------------- 1 | <*>: pkg_batteries, syntax_camlp4o, pkg_batteries.syntax, debug 2 | : pkg_netstring 3 | : thread -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) 2 | (name batteries) 3 | (version 3.10.0) 4 | 5 | (allow_approximate_merlin) ; dune requires this due to the use of prefilter.exe 6 | -------------------------------------------------------------------------------- /examples/snippets/snippets.itarget: -------------------------------------------------------------------------------- 1 | netchan_cat.byte 2 | netchan_cat.native 3 | parallelsort.byte 4 | parallelsort.native 5 | test_printf.byte 6 | test_printf.native 7 | -------------------------------------------------------------------------------- /scripts/find_since.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | # Find remaining NEXT_RELEASE tags 4 | 5 | find src/ -name '*.ml*' -exec grep NEXT_RELEASE -n {} \; -print 6 | 7 | -------------------------------------------------------------------------------- /examples/benchmark/_tags: -------------------------------------------------------------------------------- 1 | : pkg_bitstring 2 | : pkg_batteries,pkg_core,debug,pkg_threads,pkg_benchmark 3 | : pkg_batteries,pkg_core,pkg_threads 4 | -------------------------------------------------------------------------------- /test-build/test.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | 3 | let digits = List.unfold 0 (fun n -> if n >= 10 then None else Some (n, n + 1)) 4 | 5 | let () = List.iter (Int.print stdout) digits; print_newline () 6 | -------------------------------------------------------------------------------- /examples/tools/browser.ml: -------------------------------------------------------------------------------- 1 | (** 2 | Call your favorite browser to browse each of the URLs entered on the command-line. 3 | *) 4 | open Batteries_config 5 | 6 | iter (fun x -> ignore **> browse x) (args ()) 7 | -------------------------------------------------------------------------------- /src/batConcreteQueue_402.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | external of_abstr : 'a Queue.t -> 'a t = "%identity" 4 | external to_abstr : 'a t -> 'a Queue.t = "%identity" 5 | 6 | val filter_inplace : ('a -> bool) -> 'a t -> unit 7 | -------------------------------------------------------------------------------- /src/batConcreteQueue_403.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | external of_abstr : 'a Queue.t -> 'a t = "%identity" 4 | external to_abstr : 'a t -> 'a Queue.t = "%identity" 5 | 6 | val filter_inplace : ('a -> bool) -> 'a t -> unit 7 | -------------------------------------------------------------------------------- /examples/euler/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names 3 | euler001 euler008 euler009 4 | euler010 euler011 euler012 euler013 euler014 euler018 euler019 5 | euler021 euler022 euler023 euler024 6 | euler067) 7 | (libraries batteries)) 8 | -------------------------------------------------------------------------------- /qtest/README.md: -------------------------------------------------------------------------------- 1 | # qTest 2 | 3 | ## Info: 4 | The inline tests are generated and run here. The qTest code itself has moved to a new location: 5 | 6 | https://github.com/vincent-hugot/iTeML 7 | 8 | 9 | ## Files: 10 | _tags : necessary to run the tests 11 | -------------------------------------------------------------------------------- /src/batteriesThread.ml: -------------------------------------------------------------------------------- 1 | module Mutex = BatMutex 2 | module RMutex = BatRMutex 3 | 4 | let () = 5 | BatUnix.lock := RMutex.make (); 6 | BatIO.lock := RMutex.make (); 7 | BatIO.lock_factory := RMutex.make; 8 | BatPervasives.lock := RMutex.make (); 9 | () 10 | -------------------------------------------------------------------------------- /toplevel/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name batteries_top) 3 | (public_name batteries.top) 4 | (synopsis "Bytecode toplevel support for Batteries") 5 | (libraries num threads str compiler-libs batteries) 6 | (modules batteriesHelp) 7 | (modes byte) 8 | (wrapped false) 9 | ) 10 | -------------------------------------------------------------------------------- /scripts/install_deps.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # if you want to 'make clean && make && make test' batteries under 4 | # a freshly created ocaml compiler switch, this script will install 5 | # all the required dependencies 6 | 7 | opam install benchmark camlp-streams dune num ounit qtest 8 | -------------------------------------------------------------------------------- /examples/tools/shuffle.ml: -------------------------------------------------------------------------------- 1 | (* Randomly reorder the elements given on the command-line. 2 | 3 | Usage: 4 | ./shuffle 1 2 3 4 5 6 7 8 9 5 | *) 6 | 7 | open Random with self_init () 8 | 9 | let _ = Array.print ~sep:" " ~first:"" ~last:"\n" output_string stdout (shuffle (args ()));; 10 | -------------------------------------------------------------------------------- /examples/tools/shuffle2.ml: -------------------------------------------------------------------------------- 1 | (*Randomly reorder the elements given on stdin. 2 | 3 | Usage: 4 | ./shuffle2.byte < some_file.txt 5 | *) 6 | 7 | open Random with self_init () 8 | open IO, Printf 9 | 10 | let shift x = x + 1;; 11 | 12 | Array.iteri (shift |- printf "%-2d: %s\n") (shuffle (lines_of stdin)) 13 | 14 | -------------------------------------------------------------------------------- /examples/tools/tools.itarget: -------------------------------------------------------------------------------- 1 | conv.byte 2 | conv.native 3 | now.byte 4 | now.native 5 | cat.byte 6 | cat.native 7 | cat2.byte 8 | cat2.native 9 | shuffle.byte 10 | shuffle.native 11 | shuffle2.byte 12 | shuffle2.native 13 | gzip.byte 14 | gzip.native 15 | gunzip.byte 16 | gunzip.native 17 | browser.byte 18 | browser.native -------------------------------------------------------------------------------- /benchsuite/README: -------------------------------------------------------------------------------- 1 | The purpose of this directory is to provide performance evaluations of 2 | Batteries functions implementations. This is specially useful when 3 | testing changes against an upstream library such as INRIA's stdlib or 4 | Extlib. 5 | The benchmarks rely on the Ocaml [benchmark] library. 6 | 7 | [benchmark] http://forge.ocamlcore.org/projects/ocaml-benchmark/ 8 | -------------------------------------------------------------------------------- /examples/tools/cat.ml: -------------------------------------------------------------------------------- 1 | (** Implementation of a cat-like tool: read each file whose name is 2 | given on the command-line and print the contents to stdout. 3 | 4 | Compilation: 5 | ocamlbuild cat.byte 6 | 7 | Usage: 8 | ./cat.byte *.ml 9 | 10 | *) 11 | 12 | open Batteries;; 13 | 14 | iter (fun x -> IO.copy (File.open_in x) stdout) (args ());; 15 | -------------------------------------------------------------------------------- /examples/tools/mygzip.ml: -------------------------------------------------------------------------------- 1 | (* Compress a file to .gz on the spot 2 | 3 | Usage: 4 | ./gzip.byte some_file 5 | (produces some_file.gz, removes some_file) 6 | *) 7 | open File, IO, Filename 8 | 9 | iter f (args ()) 10 | where let f name = 11 | with_file_out (name ^ ".gz") (fun out -> 12 | with_file_in name (fun inp -> 13 | copy inp (Gzip.compress out); 14 | Sys.remove name 15 | )) 16 | -------------------------------------------------------------------------------- /examples/euler/euler014.ml: -------------------------------------------------------------------------------- 1 | let rec seq i = function 2 | 1 -> i 3 | | n when n land 1 = 0 -> seq (i+1) (n asr 1) 4 | | n (* odd *) -> seq (i+1) (3*n+1) 5 | 6 | let () = 7 | let best_i = ref 1 8 | and best_n0 = ref 1 in 9 | for n = 1 to 1_000_000 do 10 | let i = seq 1 n in 11 | if i > !best_i then 12 | ( best_i := i; best_n0 := n ); 13 | done; 14 | print_int !best_n0; print_newline () 15 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | _build 3 | build/META 4 | build/make_suite 5 | src/batteries_config.ml 6 | doc/batteries/html/api/ 7 | hdoc/* 8 | man/* 9 | *.byte 10 | *.native 11 | /.omake* 12 | *.swp 13 | *.opt 14 | *.run 15 | apidocs 16 | batteries.docdir 17 | batteries.odocl 18 | qtest/*_t.ml 19 | qtest/test_mods.mllib 20 | bench.log 21 | qtest/all_tests.ml 22 | qtest2/all_tests.ml 23 | qtest.targets.log 24 | setup.data 25 | setup.log 26 | -------------------------------------------------------------------------------- /examples/euler/Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean 2 | 3 | SOURCES = $(wildcard euler*.ml) 4 | TARGETS = $(SOURCES:.ml=.byte) 5 | LIBRARIES = mathlib.ml 6 | 7 | all: $(TARGETS) 8 | 9 | clean: 10 | rm *.byte *.native *.cmi *.cmo 11 | 12 | %.byte: $(LIBRARIES) %.ml 13 | ocamlfind ocamlc -thread -package threads,batteries -linkpkg $^ -o $@ 14 | 15 | %.native: $(LIBRARIES) %.ml 16 | ocamlfind ocamlc -thread -package threads,batteries -linkpkg $^ -o $@ -------------------------------------------------------------------------------- /benchsuite/flip.ml: -------------------------------------------------------------------------------- 1 | open BatPervasives 2 | open BatSet 3 | 4 | let of_list l = List.fold_left (flip add) empty l 5 | let of_list2 l = List.fold_left (fun x y -> add y x) empty l 6 | let of_list3 l = BatList.enum l |> BatSet.of_enum 7 | 8 | let wrap f () = f [1;3;5;7;9;2;4;6;8;10; 2; 5; 8; 3; 1; 9; 6] 9 | 10 | let () = Bench.bench ["flip", wrap of_list; 11 | "fun", wrap of_list2; 12 | "enum", wrap of_list3] 13 | -------------------------------------------------------------------------------- /test-build/Makefile: -------------------------------------------------------------------------------- 1 | # This test is designed to catch build issues that affect installed 2 | # versions of the library, such as the ones that plagued v2.5.0 and 3 | # v2.5.1 -- forgetting to include a new module in src/batteries.mllib, 4 | # which results in a link-time error when building from an installed 5 | # version. 6 | all: 7 | ocamlfind ocamlopt -package batteries -o test -linkpkg test.ml 8 | ./test | grep --quiet "0123456789" || exit 2 9 | rm test.cm* test.o test 10 | -------------------------------------------------------------------------------- /README.folders: -------------------------------------------------------------------------------- 1 | The following directories contain: 2 | 3 | * benchsuite/ provide performance evaluations of Batteries functions 4 | * build/ various (old) files needed for building 5 | * examples/ example files showing how to use various features of batteries 6 | * qtest/ the inline tests 7 | * src/ the core of Batteries Included, all the batFoo modules 8 | * toplevel/ Batteries helpers for the toplevel 9 | * testsuite/ a testsuite for batteries, in addition to inline tests in src/ 10 | -------------------------------------------------------------------------------- /examples/euler/euler009.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let max_search = 100 in 3 | for n = 1 to max_search do 4 | for m = n+1 to max_search do 5 | let a = 2 * m * n 6 | and b = m * m - n * n 7 | and c = m * m + n * n 8 | in 9 | let s = a + b + c in 10 | if 1000 mod s = 0 then 11 | let m = (1000 / s) in 12 | Printf.printf "mult: %d\n" m; 13 | Printf.printf "a: %d b: %d c: %d\n" (a*m) (b*m) (c*m); 14 | print_int (a * b * c * m * m * m); print_newline (); 15 | exit 0 16 | done; 17 | done 18 | -------------------------------------------------------------------------------- /examples/euler/euler010.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Enum 3 | 4 | let max_val = 2_000_000 5 | let max_test = max_val |> float |> sqrt |> Float.to_int 6 | 7 | let () = 8 | let primes = ref (2--max_val) in 9 | let s = ref 0 in 10 | let rec loop () = 11 | match get !primes with 12 | | None -> print_int !s; print_newline () 13 | | Some p -> 14 | s := !s + p; 15 | if p < max_test then 16 | primes := !primes // (fun x -> x mod p != 0); (* damn inefficient *) 17 | loop() 18 | in 19 | loop () 20 | -------------------------------------------------------------------------------- /scripts/replace_since.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env sh 2 | 3 | # Replace annotations of the form @since NEXT_RELEASE by the 4 | # version number given on the command line 5 | 6 | VERSION="$1" 7 | 8 | echo "version number: $VERSION" 9 | 10 | if [ -z "$VERSION" ] ; then 11 | echo "please give a version number, for example:" 12 | echo "sh scripts/replace_since.sh 2.8.0" 13 | exit 1 14 | fi 15 | 16 | sed -e "s/NEXT_RELEASE/$VERSION/" -i '' VERSION 17 | find src/ -name '*.ml*' -exec sed -e "s/NEXT_RELEASE/$VERSION/g" -i '' {} \; 18 | -------------------------------------------------------------------------------- /examples/euler/euler023.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | 3 | let is_abundant n = n < Mathlib.sum_factors n 4 | 5 | let max_sum = if Array.length Sys.argv > 1 6 | then int_of_string Sys.argv.(1) else 28123 7 | 8 | let () = 9 | let x = BitSet.create_full max_sum in 10 | let found = RefList.empty () in 11 | for i = 12 to max_sum do 12 | if is_abundant i then begin 13 | RefList.push found i; 14 | RefList.iter (fun j -> BitSet.unset x (i+j)) found; 15 | end 16 | done; 17 | 18 | BitSet.enum x 19 | |> Enum.reduce (+) |> print_int; 20 | 21 | print_newline () 22 | -------------------------------------------------------------------------------- /scripts/test_install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | #set -x 4 | 5 | temp_dir=`mktemp -d` 6 | 7 | cat< $temp_dir/install_test.ml 8 | open Batteries 9 | let () = 10 | assert(List.takedrop 2 [1;2;3;4] = ([1;2], [3;4])); 11 | Printf.printf "install_test: OK\n" 12 | EOF 13 | 14 | make clean # force rebuild next 15 | make install && \ 16 | cd $temp_dir && \ 17 | rm -f install_test.native && \ 18 | ocamlbuild -pkg batteries install_test.native && \ 19 | ./install_test.native 20 | 21 | cd - # go back where we were before 22 | rm -rf $temp_dir # clean our mess 23 | -------------------------------------------------------------------------------- /examples/euler/euler001.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Enum 3 | 4 | let say e = e |> map string_of_int |> print ~last:"\n" IO.nwrite stdout 5 | let print_sum e = e |> reduce (+) |> string_of_int |> print_endline 6 | 7 | let top = 999 8 | 9 | let () = 10 | (1 -- top) 11 | |> filter (fun x -> x mod 3 = 0 || x mod 5 = 0) 12 | |> print_sum 13 | 14 | let () = 15 | let mul3 = (1 -- (top / 3)) |> map ( ( * ) 3) 16 | and mul5 = (1 -- (top / 5)) |> map ( ( * ) 5) 17 | in 18 | (* say (clone mul3); 19 | say (clone mul5); *) 20 | merge (<) mul3 mul5 |> uniq |> print_sum 21 | 22 | -------------------------------------------------------------------------------- /qtest/qtest_preamble.ml: -------------------------------------------------------------------------------- 1 | (* this file is part of Batteries 'qtest' usage; it will be included 2 | at the top of the generated test runner, and is therefore a good 3 | location to add functions that would be convenient to write tests 4 | but have not yet found their place into Batteries proper. *) 5 | open Batteries 6 | 7 | module Pervasives = BatPervasives[@warning "-3"] 8 | [@@@warning "-52"] (* allow to match the constant payload of exception constructors *) 9 | [@@@warning "-unused-open"] 10 | [@@@warning "-unused-var-strict"] 11 | [@@@warning "-unused-for-index"] 12 | 13 | -------------------------------------------------------------------------------- /benchsuite/bench_num.ml: -------------------------------------------------------------------------------- 1 | let lt1 (x:int) y = x < y 2 | let lt2 x y = x < y 3 | let lt3 x y = BatInt.Compare.(<) x y 4 | 5 | let n = 100_000 6 | 7 | let test_array = Array.init n (fun _ -> BatRandom.full_range_int ()) 8 | 9 | let test_f f niters = 10 | for _j = 1 to niters do 11 | for i = 1 to n-1 do 12 | let x = test_array.(i-1) in 13 | let y = test_array.(i) in 14 | ignore (f x y); 15 | done 16 | done 17 | 18 | let () = Bench.bench_n [ 19 | "Specialized", test_f lt1; 20 | "Polymorphic", test_f lt2; 21 | "BatInt.Compare", test_f lt3; 22 | ] |> Bench.run_outputs 23 | -------------------------------------------------------------------------------- /testsuite/test_multipmap.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatPervasives 3 | open BatMultiPMap 4 | 5 | let test_multimap_empty_assoc_lists () = 6 | let map = 7 | add 0 "foo" empty |> add 0 "bar" |> add 0 "sna" |> 8 | remove 0 "foo" |> remove 0 "bar" |> remove 0 "sna" 9 | in 10 | if mem 0 map then 11 | assert_failure 12 | (Printf.sprintf "map[0] should be empty but contains %d bindings\n" 13 | (BatSet.PSet.cardinal (find 0 map))) 14 | 15 | let tests = "MultiPMap" >::: [ 16 | "MultiPMap: removing empty association lists" >:: test_multimap_empty_assoc_lists; 17 | ] 18 | -------------------------------------------------------------------------------- /examples/tools/gunzip.ml: -------------------------------------------------------------------------------- 1 | (* Open a .gz file and decompress it on the spot. 2 | 3 | Usage: 4 | ./gunzip.byte some_file.gz 5 | (produces some_file, removes some_file.gz) 6 | *) 7 | open File, IO, Filename 8 | 9 | iter f (args ()) 10 | where let f name = 11 | if check_suffix name ".gz" then 12 | with_file_in name (fun inp -> 13 | with_file_out (chop_suffix name ".gz") (fun out -> 14 | Gzip.with_in inp (fun inp'-> 15 | copy inp' out; 16 | Sys.remove name))) 17 | else prerr_endline ("I don't know what to do with file "^name) 18 | -------------------------------------------------------------------------------- /testsuite/test_dynarray.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open OUnit 3 | 4 | module DA = DynArray 5 | 6 | let s1 = DA.of_list [1;2;3] 7 | let s2 = DA.of_list [1;2] 8 | 9 | let asseq_int = assert_equal ~printer:(DA.print Int.print |> IO.to_string) 10 | let asseq_str = assert_equal ~printer:identity 11 | 12 | let test_dynarray_filter () = 13 | let e = BatDynArray.create () in 14 | BatDynArray.add e "a"; 15 | BatDynArray.add e "b"; 16 | BatDynArray.keep ((=) "a") e; 17 | asseq_str (BatDynArray.get e 0) "a" 18 | 19 | 20 | let tests = "Set" >::: [ 21 | "Dynarray_filter" >:: test_dynarray_filter; 22 | ] 23 | -------------------------------------------------------------------------------- /examples/euler/euler012.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | let num_div x = 3 | let count = ref 1 in (* already counted 1 *) 4 | let max_test = x |> float |> sqrt |> Float.to_int in 5 | for i = 2 to max_test do 6 | if x mod i = 0 then incr count 7 | done; 8 | count := !count * 2; (* every factor < max_test has a corresponding one > *) 9 | if x mod max_test = 0 then decr count; (* don't double count root if x square *) 10 | !count 11 | 12 | let rec loop i n = 13 | let d = num_div n in 14 | if d > 500 then begin 15 | print_int n; print_newline(); exit 0 16 | end else loop (i+1) (n+i+1) 17 | 18 | let () = loop 1 1 19 | -------------------------------------------------------------------------------- /examples/snippets/netchan_cat.ml: -------------------------------------------------------------------------------- 1 | (* Yet another (slower) "cat" implementation, it is just meant to be a 2 | showcase for integration with ocamlnet's Netchannels. *) 3 | 4 | let oc = 5 | Netchannels.lift_out 6 | (`Rec (new Netchannels.channel_of_output IO.stdout :> 7 | Netchannels.rec_out_channel)) 8 | let _ = 9 | Netchannels.with_in_obj_channel 10 | (Netchannels.lift_in (`Rec (new Netchannels.channel_of_input IO.stdin))) 11 | (fun ic -> 12 | try 13 | while true do 14 | oc # output_string (ic # input_line () ^ "\n"); 15 | oc # flush () 16 | done 17 | with End_of_file -> ()) 18 | 19 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | script: bash -ex .travis.sh 3 | env: 4 | - OCAML_VERSION=3.12.1 5 | - OCAML_VERSION=4.00.1 6 | - OCAML_VERSION=4.01.0 7 | - OCAML_VERSION=4.02.3 8 | - OCAML_VERSION=4.03.0 9 | - OCAML_VERSION=4.04.2 10 | - OCAML_VERSION=4.05.0 11 | - OCAML_VERSION=4.06.0 12 | - OCAML_VERSION=4.07.0 13 | - OCAML_VERSION=4.08.0 14 | - OCAML_VERSION=4.09.0 15 | - OCAML_VERSION=4.10.0 16 | - OCAML_VERSION=4.11.0 17 | - OCAML_VERSION=4.12.0 18 | - OCAML_VERSION=4.12.0+domains 19 | 20 | # notifications: 21 | # email: 22 | # - simon.cruanes.2007+travis@m4x.org 23 | # - add other addresses here (or batteries-devel or something?) 24 | -------------------------------------------------------------------------------- /examples/benchmark/run_tests.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ocamlbuild t_list.byte 4 | 5 | TESTS="nth map mapx folr folrx map2" 6 | for a in byte 7 | do 8 | for b in $TESTS 9 | do 10 | # echo -n ${b}_g.$a, 11 | ./t_list.$a -s 200 ${b}_g | tee data/${b}_gallium.$a 12 | # echo -n ${b}_e.$a, 13 | ./t_list.$a -s 200 ${b}_e | tee data/${b}_extlib.$a 14 | done 15 | done 16 | 17 | cd data 18 | 19 | for a in byte 20 | do 21 | for b in $TESTS 22 | do 23 | G_PRE="set logscale x; set logscale y; set terminal png; set xlabel \"List Length\"; set ylabel \"actions per second\";" 24 | echo "$G_PRE set output \"$b.$a.png\"; plot \"${b}_extlib.$a\" w lp, \"${b}_gallium.$a\" w lp" | gnuplot 25 | done 26 | done -------------------------------------------------------------------------------- /examples/README: -------------------------------------------------------------------------------- 1 | A few examples of short programs written using OCaml Batteries Included. 2 | 3 | Directory tools/ contains small tools. 4 | Directory snippets/ contains random code extracts. 5 | Directory euler/ contains solution programs to varous eulerproject.com puzzles 6 | Directory pleac/ contains the start of a PLEAC for batteries 7 | 8 | To build all these programs, install batteries and run 9 | 10 | make 11 | 12 | from each directory. If this doesn't work, steal the makefile, _tags 13 | and myocamlbuild from another example directory, make them work for 14 | the files in the new directory and send us the patch. :) Extra points 15 | for implementing a toplevel `make examples` that makes the examples. 16 | 17 | -------------------------------------------------------------------------------- /src/extlib.ml: -------------------------------------------------------------------------------- 1 | module Base64 = BatBase64 2 | module BitSet = BatBitSet 3 | module Dllist = BatDllist 4 | module DynArray = BatDynArray 5 | module Enum = BatEnum 6 | module ExtArray = struct 7 | module Array = BatArray 8 | end 9 | module ExtHashtbl = struct 10 | module Hashtbl = BatHashtbl 11 | end 12 | module ExtList = struct 13 | module List = BatList 14 | end 15 | module ExtString = struct 16 | module String = BatString 17 | end 18 | module Global = BatGlobal 19 | module IO = BatIO 20 | module OptParse = BatOptParse 21 | module Option = BatOption 22 | module PMap = BatMap 23 | module RefList = BatRefList 24 | module Std = BatPervasives 25 | module UChar = BatUChar 26 | module UTF8 = BatUTF8 27 | (* module Unzip = NOT AVAILABLE *) 28 | -------------------------------------------------------------------------------- /benchsuite/fsum.ml: -------------------------------------------------------------------------------- 1 | 2 | let rand_float _ = (BatRandom.float 2. -. 1.) *. 2. ** (float (BatRandom.int 80 - 40)) 3 | let nums = Array.init 10000 rand_float 4 | 5 | let test f () = f (BatArray.enum nums) 6 | 7 | let () = 8 | let results = Bench.bench_funs [ 9 | "Enum.reduce", test (BatEnum.reduce (+.)); 10 | "Enum.fsum (Kahan)", test BatEnum.fsum; 11 | "Array.fold", (fun () -> Array.fold_left (+.) 0. nums); 12 | "for loop", (fun () -> let s = ref 0. in for i = 0 to 9_999 do s := !s +. nums.(i); done; !s); 13 | "unsafe for loop", (fun () -> let s = ref 0. in for i = 0 to 9_999 do s := !s +. Array.unsafe_get nums i; done; !s); 14 | ] () in 15 | print_endline "For summing an array of 10K floats,"; 16 | Bench.summarize results 17 | -------------------------------------------------------------------------------- /examples/euler/euler024.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Mathlib 3 | 4 | let pos = 1_000_000 5 | 6 | let tokens = [0;1;2;3;4;5;6;7;8;9] 7 | 8 | let rec permute tokens acc pos = 9 | match tokens with 10 | [] -> List.rev (acc) 11 | | [x] -> List.rev (x :: acc) 12 | | t -> 13 | let len = List.length t in 14 | let sub_count = factorial (len-1) in 15 | let token_pos = pos / sub_count 16 | and next_pos = pos mod sub_count in 17 | let found = List.at t token_pos in 18 | Printf.printf "subperm %d: %d (pos %d clust %d) next: %d\n" pos found token_pos sub_count next_pos; 19 | permute (List.remove t found) (found::acc) next_pos 20 | 21 | let () = 22 | permute tokens [] (pos-1) |> List.iter (fun i -> print_int i); 23 | print_newline() 24 | 25 | -------------------------------------------------------------------------------- /examples/snippets/ropes_vs_strings.ml: -------------------------------------------------------------------------------- 1 | open Rope 2 | 3 | let (^^^) = append 4 | 5 | let test_strings num = 6 | let x = ref "" 7 | and s = "a" 8 | in for i = 1 to num do 9 | x := !x ^ s 10 | done 11 | 12 | let test_ropes num = 13 | let x = ref (r"") 14 | and s = r"a" 15 | in for i = 1 to num do 16 | x := !x ^^^ s 17 | done 18 | 19 | let delta f x = 20 | let t0 = Sys.time () in 21 | let _ = f x in 22 | let t1 = Sys.time () in 23 | t1 -. t0 24 | 25 | let _ = 26 | Printf.printf "Strings: %fms\n" (delta (fun () -> 27 | for i = 1 to 10 do 28 | test_strings 10000 29 | done 30 | ) ()); 31 | Printf.printf "Ropes: %fms\n" (delta (fun () -> 32 | for i = 1 to 10 do 33 | test_ropes 1000000 34 | done 35 | ) ()) 36 | 37 | 38 | -------------------------------------------------------------------------------- /examples/snippets/parallelsort.ml: -------------------------------------------------------------------------------- 1 | open Threads, Event 2 | 3 | let tasks = 5 4 | 5 | let main = 6 | let input = Sys.argv in 7 | let input_len = Array.length input in 8 | let channels = Array.init tasks (fun _ -> new_channel ()) in 9 | let part_size = input_len / tasks in 10 | let gen_part i = 11 | let len = if i=tasks-1 then (input_len) - (i * part_size) else part_size in 12 | Array.sub input (i*part_size) len 13 | in 14 | let partitions = Array.init tasks gen_part in 15 | let task (c,arr) = Array.sort compare arr; send c arr |> sync in 16 | let make_thread c arr = ignore (Thread.create task (c,arr)) in 17 | Array.iter2 make_thread channels partitions; 18 | let get_print c = c |> receive |> sync |> Array.iter print_endline in 19 | Array.iter get_print channels 20 | -------------------------------------------------------------------------------- /testsuite/test_digest.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | (*1. Compute the digest of this file using Legacy.Digest*) 4 | 5 | let legacy_result () = 6 | let inp = open_in_bin Sys.argv.(0) in 7 | let result = Digest.channel inp (-1) in 8 | close_in inp; 9 | result 10 | 11 | (*2. Compute the digest of this file using Batteries.Digest*) 12 | 13 | let batteries_result () = 14 | let inp = BatFile.open_in Sys.argv.(0) in 15 | let result = BatDigest.channel inp (-1) in 16 | BatIO.close_in inp; 17 | result 18 | 19 | (*3. Compare*) 20 | let test_legacy_against_batteries () = 21 | assert_equal ~printer:(Printf.sprintf "%S") 22 | (legacy_result ()) (batteries_result ()) 23 | 24 | let tests = "Digest" >::: [ 25 | "Comparing Legacy.Digest and MD5" >:: test_legacy_against_batteries; 26 | ] 27 | -------------------------------------------------------------------------------- /examples/tools/conv.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Convert encodings. 3 | Everything received from the standard input is converted and written onto the standard output, 4 | using the encodings specified on the command-line. 5 | 6 | Usage: 7 | ./conv ASCII UTF-8 < README 8 | *) 9 | open CharEncodings, Sys, IO 10 | 11 | try 12 | (*V1: Convert output: 13 | copy stdin (encoded_as (transcode_out (as_encoded stdout (`named argv.(1))) (`named argv.(2))))*) 14 | (*V2: Convert input*) 15 | copy (encoded_as **> transcode_in (as_encoded stdin **> `named argv.(1)) (`named argv.(2))) stdout; 16 | flush_all () 17 | with Not_found -> Print.eprintf p"Sorry, unknown encoding.\n%!" 18 | | Malformed_code -> Print.eprintf p"Error: This text is not encoded with encoding %S\n" (argv.(1)) 19 | | e -> Print.eprintf p"Error:\n%s\n%!" (Printexc.to_string e) 20 | -------------------------------------------------------------------------------- /examples/tools/cat2.ml: -------------------------------------------------------------------------------- 1 | (** Implementation of a cat-like tool: read each file whose name is 2 | given on the command-line and print the contents to stdout. 3 | 4 | Usage: 5 | ./cat2.byte *.ml 6 | 7 | Variants based on function composition 8 | *) 9 | 10 | (* 11 | For reference 12 | 13 | write_lines : unit output -> string Enum.t -> unit 14 | stdout : unit output 15 | args : unit -> string Enum.t 16 | () : unit 17 | concat : string Enum.t Enum.t -> string Enum.t 18 | map : (string -> string Enum.t) -> string Enum.t -> string Enum.t Enum.t 19 | File.lines_of:string -> string Enum.t 20 | *) 21 | 22 | (*(*Variant 1*) 23 | let _ = 24 | write_lines stdout -| concat <| map lines_of (args ()) 25 | *) 26 | 27 | (*Variant 2*) 28 | let _ = 29 | () |> args |> (File.lines_of |> map) |> concat |> (stdout |> IO.write_lines) 30 | 31 | -------------------------------------------------------------------------------- /testsuite/test_optparse.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatPervasives 3 | open BatOptParse 4 | 5 | let printer = dump 6 | 7 | let tests = "OptParse tests" >::: [ 8 | "parse empty" >:: begin function () -> 9 | let p = OptParser.make () in 10 | assert_equal ~printer [] (OptParser.parse p [||]) 11 | end; 12 | "parse no options" >:: begin function () -> 13 | let p = OptParser.make () in 14 | assert_equal ~printer ["foo"] (OptParser.parse p [|"foo"|]) 15 | end; 16 | "parse empty (only leading)" >:: begin function () -> 17 | let p = OptParser.make ~only_leading_opts:true () in 18 | assert_equal ~printer [] (OptParser.parse p [||]) 19 | end; 20 | "parse no options (only leading)" >:: begin function () -> 21 | let p = OptParser.make ~only_leading_opts:true () in 22 | assert_equal ~printer ["foo"] (OptParser.parse p [|"foo"|]) 23 | end; 24 | ] 25 | -------------------------------------------------------------------------------- /benchsuite/bench_finger_tree_enum.ml: -------------------------------------------------------------------------------- 1 | (* cd .. && ocamlbuild -use-ocamlfind benchsuite/bench_finger_tree_enum.native && _build/benchsuite/bench_finger_tree_enum.native *) 2 | 3 | module Fg = BatFingerTree 4 | 5 | let test_input = 6 | let s = ref Fg.empty in 7 | for i = 0 to 999_999 do 8 | s := Fg.snoc !s i; 9 | done; 10 | !s 11 | 12 | let () = 13 | assert (BatList.of_enum (Fg.enum test_input) = Fg.to_list test_input); 14 | assert (BatList.of_enum (Fg.backwards test_input) = Fg.to_list_backwards test_input); 15 | assert (BatList.of_enum (Fg.backwards test_input) = List.rev (Fg.to_list test_input)); 16 | () 17 | 18 | let test to_enum n = 19 | for _i = 1 to n do 20 | let enum = to_enum test_input in 21 | BatEnum.iter ignore enum 22 | done 23 | 24 | let () = 25 | Bench.bench_n [ 26 | "implemented", test Fg.enum; 27 | ] |> Bench.run_outputs 28 | -------------------------------------------------------------------------------- /benchsuite/rand_choice.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Random 3 | 4 | let choice e = 5 | let a = BatArray.of_enum e in 6 | let len = Array.length a in 7 | Array.get a (int len) 8 | 9 | let choice2 e = Enum.drop (int (Enum.count e)) e; Enum.get_exn e 10 | 11 | let choice3 e = 12 | if Enum.fast_count e then choice2 e 13 | else choice e 14 | 15 | let test n f = 16 | (* data structures to test *) 17 | let a = Array.init n identity in 18 | let b = List.init n identity in 19 | let c () = Random.enum_bits () |> Enum.take n in 20 | let d () = 1--n in 21 | fun () -> 22 | ignore (f (Array.enum a)); 23 | ignore (f (List.enum b)); 24 | ignore (f (c ())); 25 | ignore (f (d ())) 26 | 27 | let test = test 10_000 28 | 29 | let () = Bench.bench ["Choice", test choice; 30 | "Choice2", test choice2; 31 | "Choice3", test choice3; 32 | ] 33 | -------------------------------------------------------------------------------- /.travis.sh: -------------------------------------------------------------------------------- 1 | OPAM_DEPENDS="ocamlfind ounit qtest" 2 | 3 | case "$OCAML_VERSION" in 4 | 3.12.1.1.0) ppa=avsm/ocaml312+opam11 ;; 5 | 4.00.1.0.0) ppa=avsm/ocaml40+opam10 ;; 6 | 4.00.1.1.0) ppa=avsm/ocaml40+opam11 ;; 7 | 4.01.0.0.0) ppa=avsm/ocaml41+opam10 ;; 8 | 4.01.0.1.0) ppa=avsm/ppa ;; 9 | 4.0[234567].*) ppa= 10 | *) echo Unknown $OCAML_VERSION,$OPAM_VERSION; exit 1 ;; 11 | esac 12 | 13 | echo "yes" | sudo add-apt-repository ppa:$ppa 14 | sudo apt-get update -qq 15 | sudo apt-get install -qq opam 16 | export OPAMYES=1 17 | export OPAMVERBOSE=1 18 | 19 | opam init --compiler=$OCAML_VERSION 20 | eval `opam config env` 21 | 22 | echo "==== Installing $OPAM_DEPENDS ====" 23 | opam install ${OPAM_DEPENDS} 24 | 25 | echo "==== Build ====" 26 | make 27 | 28 | echo "==== Internal tests ====" 29 | make test-native 30 | 31 | echo "==== Install and use test ====" 32 | opam pin add -n -k path batteries . 33 | make test-build-from-install 34 | -------------------------------------------------------------------------------- /batteries_dev.el: -------------------------------------------------------------------------------- 1 | ;; This file contains useful things for participating to batteries 2 | ;; Right now, this consists of 3 | ;; * colorizing specially test comments (in orange) 4 | ;; 5 | ;; To use this file, simply add the following line to your .emacs: 6 | ;; (load-file "path/to/batteries/batteries_dev.el") 7 | ;; 8 | 9 | (defface test-comment-face 10 | '((t :foreground "orangered3")) 11 | "face for test comments") 12 | 13 | (add-hook 'tuareg-mode-hook 14 | '(lambda () 15 | (defun tuareg-font-lock-syntactic-face-function (state) 16 | (if (nth 3 state) font-lock-string-face 17 | (let ((start (nth 8 state))) 18 | (save-excursion 19 | (goto-char start) 20 | (if (looking-at-p "(\\*\\$[QTRE=]") 21 | 'test-comment-face 22 | (if (looking-at-p "(\\*\\*[^*]") 23 | tuareg-doc-face 24 | font-lock-comment-face)))))))) 25 | -------------------------------------------------------------------------------- /benchsuite/mid.ml: -------------------------------------------------------------------------------- 1 | let mid1 a b = 2 | if (0 <= a && 0 <= b) || (a < 0 && b < 0) then 3 | if a <= b then a + ((b-a)/2) else b + ((a-b)/2) 4 | else 5 | let s = a + b in 6 | if s >= 0 then s/2 else s - s/2 7 | 8 | let mid2 a b = (a+b)/2 9 | 10 | let mid3 a b = 11 | if (a >= 0) then 12 | if (b >= 0) then 13 | a + (b - a) / 2 14 | else 15 | (a+b) / 2 16 | else 17 | if (b < 0) then 18 | a + (b - a) / 2 19 | else 20 | (a+b) / 2 21 | 22 | let mid4 a b = 23 | if (0 <= a && 0 <= b) || (a < 0 && b < 0) then 24 | if a <= b then a + ((b-a)/2) else b + ((a-b)/2) 25 | else 26 | (a + b)/2 27 | 28 | let array_len = 10000 29 | let xs = Array.init array_len (fun _ -> BatRandom.full_range_int ()) 30 | 31 | let harn f n = 32 | for _i = 1 to n do 33 | for j = 0 to array_len-2 do 34 | ignore (f xs.(j) xs.(j+1)); 35 | done 36 | done 37 | 38 | let () = Bench.(summarize ~alpha:0.05 (bench_n ["mid1", harn mid1; "mid2", harn mid2; "mid3", harn mid3; "mid4", harn mid4])) 39 | -------------------------------------------------------------------------------- /benchsuite/grouping.ml: -------------------------------------------------------------------------------- 1 | let rec makeintervals_aux d lo hi acc = function 2 | | [] -> List.rev ((lo,hi)::acc) 3 | | h::t when h > hi+d -> makeintervals_aux d h h ((lo,hi)::acc) t 4 | | h::t (* h <= lim *) -> makeintervals_aux d lo h acc t 5 | 6 | let make_intervals d = function 7 | | [] -> [] 8 | | h::t -> makeintervals_aux d h h [] t 9 | 10 | let makeIntervals d = 11 | let merge s num = 12 | match s with 13 | | (start,stop) :: tail -> 14 | if abs(num-stop) <= d then 15 | (start,num) :: tail 16 | else 17 | (num,num) :: s 18 | | _ -> assert false 19 | in 20 | function 21 | | [] -> [] 22 | | head :: tail -> List.fold_left merge [(head,head)] tail 23 | 24 | let g = [1;3;5;9;12;13;14] 25 | 26 | let repeat f n = 27 | for _i = 1 to n do 28 | ignore (f g) 29 | done 30 | 31 | let tests = [ "fsharp", repeat (makeIntervals 2); 32 | "ocaml", repeat (make_intervals 2); 33 | ] 34 | 35 | let () = Bench.bench_n tests |> Bench.run_outputs 36 | -------------------------------------------------------------------------------- /examples/snippets/accumulator.ml: -------------------------------------------------------------------------------- 1 | (*A problem I found some time ago on Paul Graham's website. 2 | 3 | "Revenge of the Nerds yielded a collection of canonical solutions to 4 | the same problem in a number of languages. 5 | 6 | The problem: Write a function foo that takes a number n and returns a 7 | function that takes a number i, and returns n incremented by i. 8 | 9 | Note: (a) that's number, not integer, (b) that's incremented by, not plus." 10 | 11 | Solutions in other languages are available at 12 | http://www.paulgraham.com/accgen.html 13 | *) 14 | 15 | 16 | (** [adder t n] is an adder for elements of [numeric] typeclass [t], 17 | initialized with [n]*) 18 | let adder t n i = 19 | open Numeric in 20 | Ref.post r (t.add i) 21 | where r = ref n 22 | 23 | (*Examples:*) 24 | let adder_of_floats : float -> float = 25 | adder Float.operations 5. 26 | 27 | let adder_of_ints : int -> int = 28 | adder Int.operations 5 29 | 30 | let adder_of_complexes: Complex.t -> Complex.t = 31 | adder Complex.operations Complex.i 32 | -------------------------------------------------------------------------------- /examples/euler/euler021.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | let d n = Mathlib.sum_factors n 3 | 4 | module ISet = Set.Make(Int) 5 | 6 | let ret_amicable ~upto = 7 | let is_amic = ref ISet.empty 8 | and not_amic = ref ISet.empty 9 | and to_test = ref ((2--upto) |> ISet.of_enum) 10 | in 11 | let test n = (* cleanup - ugly code *) 12 | if n >= upto then () 13 | else if ISet.mem n !is_amic 14 | || ISet.mem n !not_amic then 15 | () 16 | else 17 | let dn = d n in 18 | if dn >= upto || dn = n then 19 | not_amic := !not_amic |> ISet.add n 20 | else 21 | let ddn = d dn in 22 | if n = ddn then 23 | is_amic := !is_amic |> ISet.add n |> ISet.add dn 24 | else 25 | not_amic := !not_amic |> ISet.add n 26 | in 27 | while not (ISet.is_empty !to_test) do 28 | let n = ISet.choose !to_test in 29 | to_test := !to_test |> ISet.remove n; 30 | test n 31 | done; 32 | ISet.enum !is_amic 33 | 34 | let print_int_enum e = Enum.print (fun stdout n -> IO.nwrite stdout (string_of_int n)) stdout e 35 | 36 | let () = 37 | ret_amicable ~upto:10_000 |> Enum.reduce (+) |> print_int; 38 | print_newline();; 39 | -------------------------------------------------------------------------------- /src/batBytesCompat.ml: -------------------------------------------------------------------------------- 1 | (* This compatible module contains compatibility versions of stdlib 2 | functions that are commonly used when porting code to the 3 | (string / bytes) separation, but are not available in older OCaml 4 | versions that Batteries support. 5 | 6 | We could push each function in the corresponding Batteries module 7 | (Buffer.add_subbtypes into BatBuffer, etc.), but this would have 8 | the effect of turning dependencies on the stdlib into 9 | inter-Batteries-module dependencies: any module using 10 | Buffer.add_subbtypes would then depend on the whole BatBuffer, 11 | increasing binary sizes and risk of cycles. 12 | *) 13 | 14 | ##V>=4.2##let string_init = String.init 15 | ##V<4.2##let string_init len f = 16 | ##V<4.2## let s = Bytes.create len in 17 | ##V<4.2## for i = 0 to len - 1 do 18 | ##V<4.2## Bytes.unsafe_set s i (f i) 19 | ##V<4.2## done; 20 | ##V<4.2## Bytes.unsafe_to_string s 21 | 22 | ##V>=4.2##let buffer_add_subbytes = Buffer.add_subbytes 23 | ##V<4.2##let buffer_add_subbytes = Buffer.add_substring 24 | 25 | ##V>=4.2##let buffer_to_bytes = Buffer.to_bytes 26 | ##V<4.2##let buffer_to_bytes = Buffer.contents 27 | -------------------------------------------------------------------------------- /testsuite/main.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | let all_tests = 4 | [ 5 | Test_pervasives.tests; 6 | (* Test_base64.tests; Replaced by simple quickcheck rules inline *) 7 | (* Test_unix.tests; Moved to inline tests in BatUnix *) 8 | (* Test_print.tests; 9 | Test_toplevel.tests; *) 10 | Test_map.tests; 11 | (* pmap is actually tested in test_map.ml, as they share their 12 | implementation *) 13 | Test_multipmap.tests; 14 | (* Test_vect.tests; Moved inline to BatVect *) 15 | Test_file.tests; 16 | (* Test_string.tests; Moved inline to BatString *) 17 | Test_substring.tests; 18 | Test_digest.tests; 19 | Test_enum.tests; 20 | Test_set.tests; 21 | Test_dynarray.tests; 22 | Test_stack.tests; 23 | Test_mappable.tests; 24 | Test_num.tests; 25 | Test_hashcons.tests; 26 | Test_mapfunctors.tests; 27 | Test_optparse.tests; 28 | Test_uref.tests; 29 | Test_bitset.tests; 30 | Test_container.tests; 31 | Test_random.tests; 32 | Test_bounded.tests; 33 | Test_modifiable.tests; 34 | Test_hashtbl.tests; 35 | ] 36 | 37 | let () = 38 | ignore(OUnit.run_test_tt_main ("All" >::: all_tests)); 39 | -------------------------------------------------------------------------------- /examples/benchmark/t_pow.ml: -------------------------------------------------------------------------------- 1 | let generic_pow ~zero ~one ~div_two ~mod_two ~mul:( * ) = 2 | let rec pow a n = 3 | if n = zero then one 4 | else if n = one then a 5 | else 6 | let b = pow a (div_two n) in 7 | b * b * (if mod_two n = zero then one else a) 8 | in pow 9 | 10 | let n = int_of_string (Sys.argv.(1)) 11 | 12 | let bases = Array.init n (fun _ -> Random.bits ()) 13 | and exps = Array.init n (fun _ -> Random.bits ()) 14 | 15 | let pow1 = generic_pow ~zero:0 ~one:1 ~div_two:(fun n -> n/2) ~mod_two:(fun n -> n mod 2) ~mul:( * ) 16 | 17 | let pow2 = generic_pow ~zero:0 ~one:1 ~div_two:(fun n -> n asr 1) ~mod_two:(fun n -> n land 1) ~mul:( * ) 18 | 19 | let pow3 = 20 | let rec pow a n = 21 | if n = 0 then 0 22 | else if n = 1 then a 23 | else 24 | let b = pow a (n asr 1) in 25 | b * b * (if n land 1 = 0 then 1 else a) 26 | in pow 27 | 28 | let time f = 29 | let t0 = Sys.time () in 30 | for i = 0 to n-1 do 31 | ignore (f bases.(i) exps.(i)) 32 | done; 33 | Sys.time () -. t0 34 | 35 | let () = 36 | Printf.printf "Time pow1: %f\n" (time pow1); 37 | Printf.printf "Time pow2: %f\n" (time pow2); 38 | Printf.printf "Time pow3: %f\n" (time pow3) 39 | -------------------------------------------------------------------------------- /examples/snippets/test_printf.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open Print 3 | 4 | let _ = 5 | (* Simple test *) 6 | printf p"x = (%d, %s)\n" 1 "a"; 7 | 8 | (* With flags: *) 9 | printf p"x = %04x\n" 42; 10 | 11 | (* Test with labelled directives: *) 12 | printf p"Hello %(name:s), i am ocaml version %(version:s)\n%!" 13 | ~name:(try Sys.getenv "USER" with _ -> "toto") 14 | ~version:Sys.ocaml_version; 15 | 16 | (* Printing an object: *) 17 | printf p"o = %obj\n" 18 | (object(self) 19 | method print oc = fprintf oc p"" (Oo.id self) 20 | end); 21 | 22 | (* Printing a list: *) 23 | printf p"l = %{int option list}\n" [Some 1; None; Some 2]; 24 | 25 | (* A custom directive, printing pair of integers: *) 26 | let printer_foo k (x, y) = k (fun oc -> fprintf oc p"(%d, %d)" x y) in 27 | 28 | printf p"pair = %foo\n" (42, 1024); 29 | 30 | (* A custom directive, taking multiple arguments: *) 31 | let printer_test k x y z = k (fun oc -> fprintf oc p"(%d, %d, %d)" x y z) in 32 | 33 | printf p"x = %test\n" 1 2 3; 34 | 35 | (* Labelled directives with multiple argument: *) 36 | printf p"x = %(x,y,z:test)\n" ~x:1 ~y:2 ~z:2; 37 | printf p"x = %(x,_,z:test)\n" ~x:1 2 ~z:2 38 | -------------------------------------------------------------------------------- /src/batInnerShuffle.ml: -------------------------------------------------------------------------------- 1 | let array_shuffle ?state a = 2 | let random_int state n = match state with 3 | | None -> Random.int n 4 | | Some s -> Random.State.int s n in 5 | for n = Array.length a - 1 downto 1 do 6 | let k = random_int state (n + 1) in 7 | if k <> n then begin 8 | let buf = Array.unsafe_get a n in 9 | Array.unsafe_set a n (Array.unsafe_get a k); 10 | Array.unsafe_set a k buf 11 | end 12 | done 13 | 14 | (*$Q 15 | Q.(array_of_size Gen.(2--15) small_int) (fun a -> \ 16 | let a' = Array.copy a in \ 17 | array_shuffle a'; \ 18 | (Array.to_list a' |> List.sort BatInt.compare) = \ 19 | (Array.to_list a |> List.sort BatInt.compare)) 20 | *) 21 | 22 | (*$R 23 | let rec fact = function 0 -> 1 | n -> n * fact (n - 1) in 24 | let length = 5 in 25 | let test = Array.init length (fun i -> i) in (* all elements must be distinct *) 26 | let permut_number = fact length in 27 | let histogram = Hashtbl.create permut_number in 28 | for i = 1 to 50_000 do 29 | let a = Array.copy test in 30 | array_shuffle a; 31 | Hashtbl.replace histogram a (); 32 | done; 33 | assert_bool "all permutations occur" (Hashtbl.length histogram = permut_number) 34 | *) 35 | -------------------------------------------------------------------------------- /src/batPrintexc.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatPrintexc - Extended Printexc module 3 | * Copyright (C) 1996 Xavier Leroy 4 | * 2008 David Teller, LIFO, Universite d'Orleans 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | 23 | include Printexc 24 | 25 | let pass = print 26 | let print out e = BatInnerIO.nwrite out (to_string e) 27 | let print_backtrace out = BatInnerIO.nwrite out (get_backtrace ()) 28 | -------------------------------------------------------------------------------- /examples/euler/euler018.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | let tri = 3 | [| 4 | [| 75 |]; 5 | [| 95; 64 |]; 6 | [| 17; 47; 82 |]; 7 | [| 18; 35; 87; 10 |]; 8 | [| 20; 04; 82; 47; 65 |]; 9 | [| 19; 01; 23; 75; 03; 34 |]; 10 | [| 88; 02; 77; 73; 07; 63; 67 |]; 11 | [| 99; 65; 04; 28; 06; 16; 70; 92 |]; 12 | [| 41; 41; 26; 56; 83; 40; 80; 70; 33 |]; 13 | [| 41; 48; 72; 33; 47; 32; 37; 16; 94; 29 |]; 14 | [| 53; 71; 44; 65; 25; 43; 91; 52; 97; 51; 14 |]; 15 | [| 70; 11; 33; 28; 77; 73; 17; 78; 39; 68; 17; 57 |]; 16 | [| 91; 71; 52; 38; 17; 14; 91; 43; 58; 50; 27; 29; 48 |]; 17 | [| 63; 66; 04; 68; 89; 53; 67; 30; 73; 16; 69; 87; 40; 31 |]; 18 | [| 04; 62; 98; 27; 23; 09; 70; 98; 73; 93; 38; 53; 60; 04; 23 |] 19 | |];; 20 | 21 | let () = 22 | let size = Array.length tri in 23 | print_int size; print_newline(); 24 | (* set each entry to the best possible result *) 25 | for n = 1 to size - 1 do 26 | tri.(n).(0) <- tri.(n).(0) + tri.(n-1).(0); 27 | for i = 1 to n-1 do 28 | tri.(n).(i) <- tri.(n).(i) + (max tri.(n-1).(i-1) tri.(n-1).(i)); 29 | done; 30 | tri.(n).(n) <- tri.(n).(n) + tri.(n-1).(n-1) 31 | done; 32 | Array.fold_left max (-1) tri.(size-1) |> print_int; 33 | print_newline() 34 | -------------------------------------------------------------------------------- /src/batUnit.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatUnit - Operations on Unit 3 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc. 19 | *) 20 | 21 | let unit_string = "()" 22 | 23 | type t = unit 24 | let string_of () = unit_string 25 | let of_string = function 26 | | "()" -> () 27 | | _ -> invalid_arg "Unit.of_string" 28 | let compare () () = 0 29 | let ord () () = BatOrd.Eq 30 | let equal () () = true 31 | let print out () = BatInnerIO.nwrite out unit_string 32 | -------------------------------------------------------------------------------- /testsuite/test_hashtbl.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | open OUnit 3 | 4 | (* regression tests for 5 | https://github.com/ocaml-batteries-team/batteries-included/issues/609 *) 6 | 7 | module IntIdHash = struct 8 | type t = int 9 | let hash t = t 10 | let equal = (=) 11 | end 12 | 13 | let test_issue_609_1 () = 14 | let module H = BatHashtbl.Make(IntIdHash) in 15 | let h = H.create 7 in 16 | H.replace h min_int []; 17 | let v = H.find_default h (-max_int) [] in 18 | assert_equal v [] 19 | 20 | let test_issue_609_2 () = 21 | let module H = BatHashtbl.Make(IntIdHash) in 22 | let h = H.create 7 in 23 | H.add h 0 []; 24 | H.remove_all h 0; 25 | assert_bool "0 was removed" (not (H.mem h 0)) 26 | 27 | let test_issue_1038 () = 28 | let module M = struct 29 | type t = int * string 30 | let equal ((i, _) : t) ((i', _) : t) = Int.equal i i' 31 | let hash ((_, s) : t) = Hashtbl.hash s 32 | end in 33 | let module H = BatHashtbl.Make(M) in 34 | let elem = (1, "Hello") in 35 | let h = H.of_list [(elem, ())] in 36 | assert_bool "the element is found" (H.mem h elem) 37 | 38 | let tests = "Hashtbl" >::: [ 39 | "PR#609 (1)" >:: test_issue_609_1; 40 | "PR#609 (2)" >:: test_issue_609_2; 41 | "PR#1038" >:: test_issue_1038; 42 | ] 43 | -------------------------------------------------------------------------------- /testsuite/test_stack.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | module Enum = BatEnum 3 | module Stack = BatStack 4 | module List = BatList 5 | 6 | let tests = "Stack" >::: [ 7 | "of_enum empty" >:: begin function () -> 8 | let e = Enum.empty () in 9 | let s = Stack.of_enum e in 10 | assert_bool "stack is not empty" (Stack.is_empty s); 11 | assert_equal ~printer:string_of_int 0 (Stack.length s); 12 | end; 13 | "of_enum simple" >:: begin function () -> 14 | let e = List.enum [1;2;3] in 15 | let s = Stack.of_enum e in 16 | assert_bool "stack is empty" (not (Stack.is_empty s)); 17 | assert_equal ~printer:string_of_int 3 (Stack.length s); 18 | assert_equal ~printer:string_of_int 3 (Stack.pop s); 19 | assert_equal ~printer:string_of_int 2 (Stack.pop s); 20 | assert_equal ~printer:string_of_int 1 (Stack.pop s); 21 | assert_raises Stack.Empty (fun () -> Stack.pop s); 22 | end; 23 | "enum empty" >:: begin function () -> 24 | let e = Stack.enum (Stack.create ()) in 25 | assert_bool "enum is not empty" (Enum.is_empty e); 26 | end; 27 | "enum nonempty" >:: begin function () -> 28 | let s = Stack.create () in 29 | Stack.push 5 s; 30 | Stack.push 7 s; 31 | assert_equal [7;5] (List.of_enum (Stack.enum s)); 32 | end 33 | ] 34 | -------------------------------------------------------------------------------- /examples/benchmark/t_read_stub.c: -------------------------------------------------------------------------------- 1 | #define _XOPEN_SOURCE 500 2 | 3 | #include 4 | #include 5 | #include 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | #include 12 | #include 13 | #include 14 | #include 15 | #include 16 | #include 17 | 18 | CAMLprim value caml_maid_pread(value ml_fd, value ml_buffer, value ml_off) { 19 | CAMLparam3(ml_fd, ml_buffer, ml_off); 20 | // fprintf(stderr, "### caml_maid_pread()\n"); 21 | int fd = Int_val(ml_fd); 22 | struct caml_ba_array *array = Caml_ba_array_val(ml_buffer); 23 | size_t len = caml_ba_byte_size(array); 24 | uint8_t *buf = Caml_ba_data_val(ml_buffer); 25 | off_t off = Int64_val(ml_off); 26 | 27 | ssize_t res = pread(fd, buf, len, off); 28 | 29 | // FIXME: throw exception on error? 30 | // Return -1 on EOF and 0 if there is nothing to read 31 | if (res == -1 && (errno == EAGAIN || errno == EWOULDBLOCK)) { 32 | res = 0; 33 | } else if (res == 0) { 34 | res = -1; 35 | } 36 | // fprintf(stderr, " res = %d\n", (int)res); 37 | CAMLreturn(Val_int(res)); 38 | } 39 | -------------------------------------------------------------------------------- /examples/tools/pair.ml: -------------------------------------------------------------------------------- 1 | (* 2 | Print the contents of two files, optionally using a printf-style format argument. 3 | I found this useful to write module CharEncodings, and it was a three-liner at 4 | the time (before I made it parametric). 5 | 6 | Usage: 7 | ./pair file_1 file_2 8 | ./pair file_1 file_2 "%s -> %S\n" 9 | 10 | The first usage prints the first line of file_1 followed by the first line of file_2, 11 | then the second line of file_1 followed by the second line of file_2, etc. until either 12 | file_1 or file_2 ends. 13 | 14 | The second usage does the same thing but adds characters " -> " between each line of 15 | file_1 and the corresponding line of file file_2 and puts the contents of each line 16 | of file_2 between quotes. 17 | *) 18 | 19 | open Sys 20 | 21 | (*Read the format -- this is the most complicated part of the program*) 22 | let default_format : (_, _, _, _) format4 = "%s %s\n" 23 | if Array.length argv < 2 then failwith "Missing arguments" 24 | let format = if Array.length argv = 3 then default_format 25 | else Scanf.format_from_string argv.(3) default_format 26 | in 27 | (*Actually do the deed*) 28 | Enum.iter2 29 | (fun x y -> Printf.printf format x y) 30 | (File.lines_of argv.(1)) 31 | (File.lines_of argv.(2)) 32 | -------------------------------------------------------------------------------- /src/batLexing.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatString - Additional functions for string manipulations. 3 | * Copyright (C) 1996 Xavier Leroy, INRIA Rocquencourt 4 | * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | 23 | open BatIO 24 | include Lexing 25 | 26 | let from_string = Lexing.from_string 27 | let from_function = Lexing.from_function 28 | 29 | let from_input inp = 30 | from_function (fun s n -> try input inp s 0 n with No_more_input -> 0) 31 | 32 | let from_channel = from_input 33 | -------------------------------------------------------------------------------- /src/batInterfaces.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Interfaces - Common interfaces for data structures 3 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | module type Mappable = sig 22 | type 'a mappable 23 | val map : ('a -> 'b) -> ('a mappable -> 'b mappable) 24 | end 25 | 26 | module type OrderedType = 27 | sig 28 | type t 29 | val compare : t -> t -> int 30 | end 31 | 32 | module type Monad = sig 33 | type 'a m 34 | val bind : 'a m -> ('a -> 'b m) -> 'b m 35 | val return: 'a -> 'a m 36 | end 37 | -------------------------------------------------------------------------------- /batteries.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "3.10.0" 3 | synopsis: "A community-maintained standard library extension" 4 | maintainer: [ 5 | "Cedric Cellier " 6 | "Francois Berenger " 7 | "Gabriel Scherer " 8 | "Thibault Suzanne " 9 | "Simmo Saan " 10 | ] 11 | authors: ["OCaml batteries-included team"] 12 | license: "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" 13 | homepage: "https://github.com/ocaml-batteries-team/batteries-included" 14 | doc: "http://ocaml-batteries-team.github.io/batteries-included/hdoc2/" 15 | bug-reports: 16 | "https://github.com/ocaml-batteries-team/batteries-included/issues" 17 | depends: [ 18 | "dune" {>= "2.7"} 19 | "ocaml" {>= "4.05" & < "5.5"} 20 | "camlp-streams" 21 | "ocamlfind" {>= "1.5.3"} 22 | "qtest" {with-test & >= "2.5"} 23 | "qcheck" {with-test & >= "0.9" & < "0.14"} 24 | "benchmark" {with-test & >= "1.6"} 25 | "num" 26 | "odoc" {with-doc} 27 | ] 28 | conflicts: ["ocaml-option-no-flat-float-array"] 29 | build: [ 30 | ["dune" "subst"] {dev} 31 | [ 32 | "dune" 33 | "build" 34 | "-p" 35 | name 36 | "-j" 37 | jobs {!with-test} 38 | "1" {with-test} 39 | "@install" 40 | "@runtest" {with-test} 41 | "@doc" {with-doc} 42 | ] 43 | ] 44 | dev-repo: 45 | "git+https://github.com/ocaml-batteries-team/batteries-included.git" 46 | -------------------------------------------------------------------------------- /src/batReturn.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Return -- fast return in OCaml 3 | * Copyright (C) 2008 David Teller 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | 22 | type 'a t = 'a -> exn 23 | 24 | let return label value = 25 | raise (label value) 26 | 27 | let label (type u) (f : u t -> u) : u = 28 | let module M = struct exception Return of u end in 29 | try f (fun x -> M.Return x) 30 | with M.Return u -> u 31 | let with_label = label 32 | 33 | (* testing nesting with_labels *) 34 | (*$T with_label 35 | with_label (fun label1 -> \ 36 | with_label (fun _label2 -> ignore (return label1 1)); 2 \ 37 | ) = 1 38 | *) 39 | -------------------------------------------------------------------------------- /src/batGlobal.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Global - Mutable global variable 3 | * Copyright (C) 2003 Nicolas Cannasse 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | 22 | exception Global_not_initialized of string 23 | 24 | type 'a t = ('a option ref * string) 25 | 26 | let empty name = 27 | (ref None, name) 28 | 29 | let name = snd 30 | 31 | let set (r, _) v = 32 | r := Some v 33 | 34 | let get_exn (r, name) = 35 | match !r with 36 | | None -> raise (Global_not_initialized name) 37 | | Some v -> v 38 | 39 | let undef (r, _) = 40 | r := None 41 | 42 | let isdef (r, _) = 43 | !r <> None 44 | 45 | let get (r,_) = !r 46 | -------------------------------------------------------------------------------- /testsuite/test_base64.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatBase64 3 | 4 | let string = "hello world" 5 | 6 | let assert_equal_strings s1 s2 = 7 | assert_equal ~printer:(fun s -> "“"^s^"”") s1 s2 8 | 9 | let hexa s = 10 | (* really not perf critical *) 11 | let r = ref "" in 12 | for i = 0 to String.length s - 1 do 13 | r := !r ^ (Printf.sprintf "%x" (Char.code s.[i])) 14 | done; 15 | !r 16 | 17 | let assert_equal_bytes s1 s2 = 18 | assert_equal ~printer:(fun s -> "“"^s^"” (0x"^(hexa s)^")") s1 s2 19 | 20 | let test_encdec_aux str = 21 | assert_equal_bytes str (str_decode (str_encode str)) 22 | 23 | let test_decenc_aux str = 24 | let enc = str_encode str in 25 | assert_equal_strings enc (str_encode (str_decode enc)) 26 | 27 | let random_string len = 28 | let r = String.create len in 29 | for i = 0 to len - 1 30 | do r.[i] <- BatRandom.char () done; 31 | r 32 | 33 | let map_generated_data f iters max_len = 34 | for len = 0 to max_len do 35 | for i = 1 to iters do 36 | f (random_string len) 37 | done done 38 | 39 | 40 | let test_encdec () = 41 | map_generated_data test_encdec_aux 4 50 42 | 43 | let test_decenc () = 44 | map_generated_data test_decenc_aux 4 50 45 | 46 | 47 | let tests = "Base64" >::: [ 48 | "Decode undoes encode" >:: test_encdec; 49 | "Encode undoes decode" >:: test_decenc; 50 | (*"Encode works as expected" >:: test_enc; 51 | "Decode works as expected" >:: test_dec;*) 52 | ] 53 | -------------------------------------------------------------------------------- /testsuite/test_hashcons.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatHashcons 3 | 4 | type lterm = lterm_ hobj 5 | and lterm_ = 6 | | Var of string 7 | | App of lterm * lterm 8 | | Lam of string * lterm 9 | 10 | module LtermFuncs = struct 11 | type t = lterm_ 12 | let equal lt1 lt2 = match lt1, lt2 with 13 | | Var j, Var k -> j = k 14 | | App (lt11, lt12), App (lt21, lt22) -> 15 | lt11 == lt21 && lt12 == lt22 16 | | Lam (x, lt1), Lam (y, lt2) -> 17 | x = y && lt1 == lt2 18 | | _ -> false 19 | let hash = function 20 | | Var x -> H.hc1_ 0 (Hashtbl.hash x) 21 | | App (lt1, lt2) -> H.hc1_ 1 (H.hc1 lt1 (H.hc0 lt2)) 22 | | Lam (x, lt) -> H.hc1_ 2 (H.hc1_ (Hashtbl.hash x) (H.hc0 lt)) 23 | end 24 | module LtermHC = MakeTable (LtermFuncs) 25 | let _tab = LtermHC.create 1 26 | let var x : lterm = LtermHC.hashcons _tab (Var x) 27 | let app lt1 lt2 : lterm = LtermHC.hashcons _tab (App (lt1, lt2)) 28 | let lam x lt : lterm = LtermHC.hashcons _tab (Lam (x, lt)) 29 | 30 | let test_identity () = 31 | let mk_s x y z = 32 | lam x begin 33 | lam y begin 34 | lam z begin 35 | let xz = app (var x) (var z) in 36 | let yz = app (var y) (var z) in 37 | app xz yz 38 | end 39 | end 40 | end 41 | in 42 | assert_bool "mk_s produces different objects" 43 | (mk_s "x" "y" "z" == mk_s "x" "y" "z") 44 | 45 | let tests = "Hashcons" >::: [ 46 | "Pointer identity" >:: test_identity 47 | ] 48 | -------------------------------------------------------------------------------- /benchsuite/bench_int.ml: -------------------------------------------------------------------------------- 1 | (* cd .. && ocamlbuild benchsuite/test_int.native -- *) 2 | 3 | 4 | external primitive_int_compare : int -> int -> int = "caml_int_compare" [@@noalloc] 5 | [@@warning "-3"] 6 | 7 | let std_compare = compare[@warning "-3"] 8 | 9 | let test_compare () = 10 | 11 | let length = 1000 in 12 | 13 | let input = 14 | Array.init length (fun _ -> BatRandom.(full_range_int (), full_range_int ())) in 15 | 16 | let output = Array.map (fun (x, y) -> std_compare x y) input in 17 | 18 | let test cmp n = 19 | Array.iteri (fun i (x, y) -> 20 | assert (cmp x y = output.(i)); 21 | for _i = 1 to n do 22 | ignore (cmp x y); 23 | done) 24 | input in 25 | 26 | let naive_compare x y = 27 | (* this code actually mirrors an implementation that has been used 28 | as BatInt.compare *) 29 | if x > y then 1 30 | else if y > x then -1 31 | else 0 in 32 | 33 | let mfp_compare (x : int) y = 34 | if x > y then 1 35 | else if y > x then -1 36 | else 0 in 37 | 38 | let samples = Bench.bench_n 39 | [ 40 | "BatInt.compare", test BatInt.compare; 41 | "stdlib's compare", test std_compare; 42 | "external compare", test primitive_int_compare; 43 | "mfp's compare", test mfp_compare; 44 | "naive compare", test naive_compare; 45 | ] 46 | in 47 | print_endline "For comparing 1000 pairs of random integers"; 48 | Bench.summarize samples 49 | 50 | let () = 51 | test_compare (); 52 | () 53 | -------------------------------------------------------------------------------- /examples/euler/euler008.ml: -------------------------------------------------------------------------------- 1 | 2 | let num = "73167176531330624919225119674426574742355349194934\ 3 | 96983520312774506326239578318016984801869478851843\ 4 | 85861560789112949495459501737958331952853208805511\ 5 | 12540698747158523863050715693290963295227443043557\ 6 | 66896648950445244523161731856403098711121722383113\ 7 | 62229893423380308135336276614282806444486645238749\ 8 | 30358907296290491560440772390713810515859307960866\ 9 | 70172427121883998797908792274921901699720888093776\ 10 | 65727333001053367881220235421809751254540594752243\ 11 | 52584907711670556013604839586446706324415722155397\ 12 | 53697817977846174064955149290862569321978468622482\ 13 | 83972241375657056057490261407972968652414535100474\ 14 | 82166370484403199890008895243450658541227588666881\ 15 | 16427171479924442928230863465674813919123162824586\ 16 | 17866458359124566529476545682848912883142607690042\ 17 | 24219022671055626321111109370544217506941658960408\ 18 | 07198403850962455444362981230987879927244284909188\ 19 | 84580156166097919133875499200524063689912560717606\ 20 | 05886116467109405077541002256983155200055935729725\ 21 | 71636269561882670428252483600823257530420752963450" 22 | 23 | let code0 = Char.code '0' 24 | let numarr = Array.init 1000 (fun i -> Char.code num.[i] - code0) 25 | 26 | let () = 27 | let best = ref 1 in 28 | for i = 0 to 999 - 5 do 29 | let prod5 = numarr.(i) * numarr.(i+1) * numarr.(i+2) * numarr.(i+3) * numarr.(i+4) in 30 | best := max !best prod5; 31 | done; 32 | print_int !best; print_newline () 33 | -------------------------------------------------------------------------------- /plot: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | [ $# -eq 0 ] || { 4 | echo 'unexpected command line arguments' 5 | echo 'usage: $0' 6 | echo 'Expects a stream on the standard input and draws' 7 | echo 'gnuplot graphs when it recognizes some gnuplot data' 8 | exit 1 9 | } 10 | 11 | trap cleanup EXIT SIGINT 12 | cleanup() { 13 | rm -f "$tmp" 14 | } 15 | tmp="$(mktemp)" 16 | 17 | while read line; do 18 | case "$line" in 19 | '#'*) 20 | # reading blocks of line starting with a line 21 | # starting with a sharp and ending with an empty line 22 | # this line has format #title size\tname1\tname2 etc. 23 | names=$(echo "$line" | cut -d ' ' -f 2-) 24 | title=$(echo "$line" | sed 's/^#\([^ ]*\) .*$/\1/') 25 | > "$tmp" # emptying the file 26 | while read line && [ "$line" != "" ]; do 27 | echo "$line" >> "$tmp" 28 | done 29 | gnuplot -p <( 30 | echo set key left top 31 | echo set logscale x 32 | echo set title "'$title'" 33 | echo -n 'plot ' 34 | counter=1 35 | for name in $names; do 36 | counter=$((counter+1)) 37 | if [ $counter -ne 2 ]; then 38 | echo -e -n ', \\\n ' 39 | fi 40 | echo -n \'"$tmp"\' using 1:$counter title \'"$name"\' with linespoints 41 | done 42 | echo 43 | ) 44 | esac 45 | done 46 | -------------------------------------------------------------------------------- /src/batteriesConfig.mlp: -------------------------------------------------------------------------------- 1 | (* 2 | * config - Configuration module for OCaml Batteries Included 3 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | let version = "@VERSION@";; 22 | let documentation_root = "@DOCROOT@";; 23 | let (browser: (_, _, _) format) = "@BROWSER_COMMAND@ %s";; 24 | 25 | (**The default function to open a www browser.*) 26 | let default_browse s = 27 | let command = Printf.sprintf browser s in 28 | Sys.command command 29 | let current_browse = ref default_browse 30 | 31 | let browse s = !current_browse s 32 | let set_browser f = current_browse := f 33 | 34 | let max_array_length = Sys.max_array_length 35 | let word_size = Sys.word_size 36 | let max_string_length= Sys.max_string_length 37 | -------------------------------------------------------------------------------- /toplevel/ocamlinit: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2011 Batteries Included Team 3 | * 4 | * This library is free software; you can redistribute it and/or 5 | * modify it under the terms of the GNU Lesser General Public 6 | * License as published by the Free Software Foundation; either 7 | * version 2.1 of the License, or (at your option) any later version, 8 | * with the special exception on linking described in file LICENSE. 9 | * 10 | * This library is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | * Lesser General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU Lesser General Public 16 | * License along with this library; if not, write to the Free Software 17 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 18 | *) 19 | 20 | 21 | (* This script starts loading batteries into the ocaml toplevel. 22 | * 23 | * To install, copy to your ~/.ocamlinit. If you already have an 24 | * ocamlinit file that initializes findlib, just add the last 25 | * phrase to your ocamlinit. 26 | *) 27 | 28 | (* Pretend to be in non-interactive mode to hide topfind 29 | initialization message *) 30 | 31 | let interactive = !Sys.interactive;; 32 | Sys.interactive := false;; 33 | #use "topfind";; 34 | Sys.interactive := interactive;; 35 | 36 | (* run battop.ml in toplevel *) 37 | 38 | Toploop.use_silently 39 | Format.err_formatter (Filename.concat (Findlib.package_directory 40 | "batteries") "battop.ml");; 41 | -------------------------------------------------------------------------------- /src/batSys.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatSys - additional and modified functions for System 3 | * Copyright (C) 1996 Xavier Leroy 4 | * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | let big_endian = false (* overridden by real big_endian value in 4.00 and above *) 23 | 24 | include Sys 25 | 26 | let files_of d = BatArray.enum (readdir d) 27 | 28 | ##V<4.3##let sigbus = -22 29 | ##V<4.3##let sigpoll = -23 30 | ##V<4.3##let sigsys = -24 31 | ##V<4.3##let sigtrap = -25 32 | ##V<4.3##let sigurg = -26 33 | ##V<4.3##let sigxcpu = -27 34 | ##V<4.3##let sigxfsz = -28 35 | 36 | ##V>=4.3##external opaque_identity : 'a -> 'a = "%opaque" 37 | ##V<4.3##let opaque_identity = BatOpaqueInnerSys.opaque_identity 38 | 39 | ##V<4.5##let getenv_opt v = try Some (getenv v) with Not_found -> None 40 | -------------------------------------------------------------------------------- /examples/euler/euler019.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | 3 | let daysmonth = [ 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 ] 4 | let daysleap = [ 31; 29; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 ] 5 | 6 | let year_shift_f days = (List.reduce (+) days) mod 7 7 | 8 | let year_shift = year_shift_f daysmonth (* 1 *) 9 | let year_shiftleap = year_shift_f daysleap (* 2 *) 10 | 11 | let count_shift days = 12 | let ret = Array.make 7 0 in 13 | let rec loop day = function 14 | | _h :: [] -> 15 | let sh = 6 - day in 16 | ret.(sh) <- ret.(sh) + 1 (* and done *) 17 | | [] -> assert false 18 | | h :: t -> 19 | let sh = 6 - day in 20 | ret.(sh) <- ret.(sh) + 1; 21 | loop ((day + h) mod 7) t 22 | in 23 | loop 0 days; 24 | ret 25 | 26 | let count_year = count_shift daysmonth 27 | let count_leap = count_shift daysleap 28 | (* val count_year : int array = [|2; 2; 1; 3; 1; 1; 2|] *) 29 | (* val count_leap : int array = [|2; 1; 2; 2; 1; 1; 3|] *) 30 | 31 | let is_leap yr = 32 | if yr mod 4 <> 0 then false 33 | else if yr mod 100 <> 0 then true 34 | else if yr mod 400 <> 0 then false 35 | else true 36 | 37 | let rec count_sun (count, yr, endyr, dayone) = 38 | if yr >= endyr then count 39 | else 40 | let add, shift = 41 | if is_leap yr 42 | then count_leap.(dayone), year_shiftleap 43 | else count_year.(dayone), year_shift 44 | in 45 | count_sun ((count+add), (yr+1), endyr, ((dayone + shift) mod 7)) 46 | 47 | let () = 48 | let end_yr = 2001 49 | and start_yr = 1901 50 | and dayone = 1 (* monday *) 51 | in 52 | let count = count_sun (0, start_yr, end_yr, dayone) in 53 | print_int count; print_newline();; 54 | -------------------------------------------------------------------------------- /testsuite/test_unix.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatPrintf 3 | open BatIO 4 | 5 | let string = "hello world" 6 | 7 | let test_open_process_readline () = 8 | try 9 | let r,w = BatUnix.open_process "cat" in 10 | fprintf w "%s\n" string; 11 | close_out w; 12 | match BatIO.read_line r with 13 | | s when s = string -> () 14 | | s -> assert_failure (BatPrintf.sprintf "Expected %S, got %S" string s) 15 | with e -> assert_failure (BatPrintf.sprintf "Expected %S, got exception %s" string (Printexc.to_string e)) 16 | 17 | let test_open_process_cleanup () = 18 | try 19 | let r,w = BatUnix.open_process "cat" in 20 | BatPrintf.fprintf w "%s\n" string; 21 | close_out w; 22 | while true do 23 | ignore (BatPervasives.input_char r) (*This is a way of checking that the process is closed.*) 24 | done 25 | with End_of_file 26 | | No_more_input -> () 27 | | e -> assert_failure (BatPrintf.sprintf "Expected %S, got exception %s" string (Printexc.to_string e)) 28 | 29 | 30 | (*let test_open_process_close_process () = (*Actually, this test shouldn't work*) 31 | try 32 | let r,w = Unix.open_process "cat" in 33 | fprintf w p"%s\n" string; 34 | ignore (Unix.close_process (r, w)); 35 | while true do 36 | ignore (input_char r); (*This is a way of checking that the process is closed.*) 37 | done 38 | with End_of_file 39 | | No_more_input -> () 40 | | e -> assert_failure (sprintf p"Expected %S, got exception %exn" string e)*) 41 | 42 | let tests = "Unix" >::: [ 43 | "Open process, then read_line" >:: test_open_process_readline; 44 | "Open process, then clean up" >:: test_open_process_cleanup 45 | ] 46 | -------------------------------------------------------------------------------- /testsuite/test_vect.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatVect 3 | open BatPervasives 4 | 5 | (**Initialize data sample*) 6 | let state = BatRandom.State.make [|0|] 7 | let buffer = BatArray.of_enum (BatEnum.take 1000 (BatRandom.State.enum_int state 255)) 8 | let vect = of_array buffer 9 | 10 | let print_array out = 11 | BatArray.print ~sep:"; " BatInt.print out 12 | let print_vect out = 13 | BatVect.print ~sep:"; " BatInt.print out 14 | 15 | let sprint_vect v = BatPrintf.sprintf2 "%a" print_vect v 16 | 17 | let test_array_conversion () = 18 | assert_equal ~printer:sprint_vect 19 | vect 20 | (to_array vect |> of_array |> to_array |> of_array) 21 | 22 | let test_init () = 23 | let f i = i * i in 24 | let vect = init 1000 f 25 | and array = Array.init 1000 f 26 | in 27 | if BatEnum.compare ( BatInt.compare ) (enum vect) (BatArray.enum array) = 0 then 28 | () (* pass *) 29 | else assert_failure 30 | (BatPrintf.sprintf2 "Hoping: %a\n\tGot: %a" print_array array print_vect vect) 31 | 32 | let test_fold_left () = 33 | let f i = i * i 34 | and g i j = i * i + j in 35 | let vect = fold_left g 0 (init 1000 f) 36 | and array = Array.fold_left g 0 (Array.init 1000 f) 37 | in 38 | assert_equal ~printer:string_of_int array vect 39 | 40 | let test_fold_right () = 41 | let f i = i * i 42 | and g i j = i * i + j in 43 | let vect = fold_right g (init 1000 f) 0 44 | and array = Array.fold_right g (Array.init 1000 f) 0 45 | in 46 | assert_equal ~printer:string_of_int array vect 47 | 48 | let tests = "Vect" >::: [ 49 | "Converting to/from array" >:: test_array_conversion; 50 | "Init" >:: test_init; 51 | "Fold_left" >:: test_fold_left; 52 | "Fold_right" >:: test_fold_right; 53 | ] 54 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: ci 2 | 3 | on: 4 | push: 5 | pull_request: 6 | workflow_dispatch: 7 | 8 | jobs: 9 | build-dune: 10 | strategy: 11 | fail-fast: false 12 | 13 | matrix: 14 | os: 15 | - ubuntu-latest 16 | ocaml-compiler: 17 | - ocaml-base-compiler.5.4.0~beta1 18 | - 5.3.x 19 | - 5.2.x 20 | - 5.1.x 21 | - 5.0.x 22 | - 4.14.x 23 | - 4.13.x 24 | - 4.12.x 25 | - 4.11.x 26 | - 4.10.x 27 | - 4.09.x 28 | - 4.08.x 29 | - 4.07.x 30 | - 4.06.x 31 | - 4.05.x 32 | test: 33 | - true 34 | 35 | include: 36 | - os: ubuntu-latest 37 | ocaml-compiler: 4.02.3 38 | test: false 39 | - os: macos-latest 40 | ocaml-compiler: 4.14.x 41 | test: true 42 | - os: macos-latest 43 | ocaml-compiler: 5.0.0 44 | test: true 45 | 46 | runs-on: ${{ matrix.os }} 47 | 48 | steps: 49 | - name: Checkout code 50 | uses: actions/checkout@v3 51 | 52 | - name: Set up OCaml ${{ matrix.ocaml-compiler }} 53 | uses: ocaml/setup-ocaml@v3 54 | with: 55 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 56 | 57 | - name: Install dependencies 58 | run: opam install . --deps-only 59 | 60 | - name: Install test dependencies 61 | if: ${{ matrix.test }} 62 | run: opam install . --deps-only --with-test 63 | 64 | - name: Build 65 | run: opam exec -- dune build @install 66 | 67 | - name: Test 68 | if: ${{ matrix.test }} 69 | run: opam exec -- dune runtest 70 | -------------------------------------------------------------------------------- /src/batAvlTree.mli: -------------------------------------------------------------------------------- 1 | (* Copyright 2003 Yamagata Yoriyuki. distributed with LGPL *) 2 | (* Modified by Edgar Friendly *) 3 | 4 | (** Internals of ISet and IMap, usable as generic tree library *) 5 | 6 | type +'a tree 7 | 8 | val empty : 'a tree 9 | 10 | val is_empty : 'a tree -> bool 11 | 12 | val make_tree : 'a tree -> 'a -> 'a tree -> 'a tree 13 | 14 | val create : 'a tree -> 'a -> 'a tree -> 'a tree 15 | (** [create l v r] is similar to [make_tree l v r] but performs no rebalancing; 16 | in other words, you should use this only when you {e know} that [l] and [r] 17 | are already balanced. *) 18 | 19 | val height : 'a tree -> int 20 | 21 | val left_branch : 'a tree -> 'a tree 22 | (** @raise Not_found if the tree is empty *) 23 | 24 | val right_branch : 'a tree -> 'a tree 25 | (** @raise Not_found if the tree is empty *) 26 | 27 | val root : 'a tree -> 'a 28 | (** @raise Not_found if the tree is empty *) 29 | 30 | (* Utilities *) 31 | val singleton_tree : 'a -> 'a tree 32 | val split_leftmost : 'a tree -> 'a * 'a tree 33 | val split_rightmost : 'a tree -> 'a * 'a tree 34 | 35 | val concat : 'a tree -> 'a tree -> 'a tree 36 | 37 | val iter : ('a -> unit) -> 'a tree -> unit 38 | 39 | val fold : ('a -> 'b -> 'b) -> 'a tree -> 'b -> 'b 40 | 41 | val enum : 'a tree -> 'a BatEnum.t 42 | 43 | (* Sanity checks *) 44 | 45 | val check : 'a tree -> bool 46 | (** Check that the tree is balanced according to the AVL tree rules. 47 | An AVL tree is balanced when for every node the height of the 48 | subnodes differs by at most 1. 49 | 50 | @since 2.3.0 51 | *) 52 | 53 | (**/**) 54 | (* Helpers for testing *) 55 | 56 | val check_height_cache : 'a tree -> bool 57 | val check_height_balance : 'a tree -> bool 58 | 59 | (**/**) 60 | -------------------------------------------------------------------------------- /src/batUnit.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * BatUnit - Operations on Unit 3 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc. 19 | *) 20 | 21 | (** 22 | Operations on [unit]. 23 | 24 | @author David Teller 25 | *) 26 | 27 | type t = unit 28 | (**The unit type, i.e. a type with only one element, [()].*) 29 | 30 | val string_of : t -> string 31 | (**Convert the given unit to a string. 32 | 33 | Returns ["()"]. *) 34 | 35 | val of_string : string -> t 36 | (**Convert the given string to a unit. 37 | 38 | Accepts ["()"]. 39 | @raise Invalid_argument if the given string is not ["()"]. 40 | *) 41 | 42 | val compare : t -> t -> int 43 | (** Compare two units. 44 | 45 | Always returns 0.*) 46 | 47 | val ord : t -> t -> BatOrd.order 48 | (** Always returns [BatOrd.Eq] *) 49 | 50 | val equal : t -> t -> bool 51 | (** Always returns true. *) 52 | 53 | (** {1 Boilerplate code}*) 54 | 55 | (** {2 Printing}*) 56 | val print: 'a BatInnerIO.output -> unit -> unit 57 | -------------------------------------------------------------------------------- /benchsuite/dynarray_iter.ml: -------------------------------------------------------------------------------- 1 | type dynarray = { 2 | mutable len : int; 3 | mutable array : int array; 4 | (* int array to have cheap Array.get, 5 | like in batDynArray *) 6 | } 7 | 8 | let len = 1000 9 | let d = { 10 | len; 11 | array = Array.make len 42; 12 | } 13 | 14 | let unsafe_iter f d = 15 | for i = 0 to d.len - 1 do 16 | f d.array.(i) 17 | done 18 | 19 | let unsafe_iter2 f d = 20 | let a = d.array in 21 | for i = 0 to d.len - 1 do 22 | f a.(i) 23 | done 24 | 25 | let iter f d = 26 | let a = d.array in 27 | let len = d.len in 28 | for i = 0 to len - 1 do 29 | f a.(i); 30 | if d.array != a || d.len <> len then failwith "whatever" 31 | done 32 | 33 | let iter2 f d = 34 | let a = d.array in 35 | let i = ref 0 in 36 | let len = d.len in 37 | while !i < d.len && !i < len do 38 | f a.(!i); 39 | incr i 40 | done 41 | 42 | let iter3 f d = 43 | let i = ref 0 in 44 | while !i < d.len do 45 | f d.array.(!i); 46 | incr i 47 | done 48 | 49 | let test iter n = 50 | for i = 0 to n - 1 do 51 | ignore i; 52 | iter ignore d 53 | done 54 | 55 | let for_ n = 56 | for i = 0 to n - 1 do 57 | ignore i; 58 | for i = 0 to d.len - 1 do 59 | ignore d.array.(i) 60 | done 61 | done 62 | 63 | let for2 n = 64 | for i = 0 to n - 1 do 65 | ignore i; 66 | let a = d.array in 67 | for i = 0 to d.len - 1 do 68 | ignore a.(i) 69 | done 70 | done 71 | 72 | let () = 73 | let readings = 74 | Bench.bench_n [ 75 | "unsafe_iter", test unsafe_iter; 76 | "unsafe_iter2", test unsafe_iter2; 77 | "iter", test iter; 78 | "iter2", test iter2; 79 | "iter3", test iter3; 80 | "for_", for_; 81 | "for2", for2; 82 | ] in 83 | Bench.summarize readings 84 | -------------------------------------------------------------------------------- /src/batConcreteQueue_403.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-37"] 2 | (* Disable warning 37 (Unused constructor): 3 | Cons is never used to build values, 4 | but it is used implicitly in [of_abstr] *) 5 | type 'a cell = 6 | | Nil 7 | | Cons of { content: 'a; mutable next: 'a cell } 8 | 9 | 10 | type 'a t = { 11 | mutable length: int; 12 | mutable first: 'a cell; 13 | mutable last: 'a cell 14 | } 15 | 16 | external of_abstr : 'a Queue.t -> 'a t = "%identity" 17 | external to_abstr : 'a t -> 'a Queue.t = "%identity" 18 | 19 | let filter_inplace f queue = 20 | (* find_next returns the next 'true' cell, or Nil *) 21 | let rec find_next = function 22 | | Nil -> Nil 23 | | (Cons cell) as cons -> 24 | if f cell.content then cons 25 | else find_next cell.next 26 | in 27 | (* last is the last known 'true' Cons cell 28 | (may be Nil if no true cell has be found yet) 29 | next is the next candidate true cell 30 | (may be Nil if there is no next cell) *) 31 | let rec loop length last next = match next with 32 | | Nil -> (length, last) 33 | | (Cons cell) as cons -> 34 | let next = find_next cell.next in 35 | cell.next <- next; 36 | loop (length + 1) cons next 37 | in 38 | let first = find_next queue.first in 39 | (* returning a pair is unnecessary, the writes could be made at the 40 | end of 'loop', but the present style makes it obvious that all 41 | three writes are performed atomically, without allocation, 42 | function call or return (yield points) in between, guaranteeing 43 | some form of state consistency in the face of signals, threading 44 | or what not. *) 45 | let (length, last) = loop 0 Nil first in 46 | queue.length <- length; 47 | queue.first <- first; 48 | queue.last <- last; 49 | () 50 | -------------------------------------------------------------------------------- /src/batScanf.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatScanf - Extended Scanf module 3 | * Copyright (C) 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | 22 | module Scanning = 23 | struct 24 | include Scanf.Scanning 25 | 26 | let from_input inp = 27 | from_function (fun () -> try BatInnerIO.read inp with BatInnerIO.No_more_input -> raise End_of_file) 28 | (*$T 29 | bscanf (Scanning.from_input (BatIO.input_string "12 bc" )) "%d %s" (fun d s -> d = 12 && s = "bc") 30 | *) 31 | 32 | let from_channel = from_input 33 | 34 | let stdib = from_input (BatInnerIO.stdin) 35 | end 36 | 37 | type ('a, 'b, 'c, 'd) scanner = 38 | ('a, Scanning.scanbuf, 'b, 'c, 'a -> 'd, 'd) format6 -> 'c 39 | 40 | 41 | open Scanf 42 | ##V<5##let fscanf = fscanf 43 | let sscanf = sscanf 44 | let scanf = scanf 45 | let kscanf = kscanf 46 | let bscanf = bscanf 47 | let bscanf_format = bscanf_format 48 | let sscanf_format = sscanf_format 49 | let format_from_string = format_from_string 50 | exception Scan_failure = Scan_failure 51 | -------------------------------------------------------------------------------- /testsuite/test_mapfunctors.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatRandom 3 | 4 | module MkTest (MkMap : functor (Ord : BatInterfaces.OrderedType) 5 | -> BatMap.S with type key = Ord.t) = 6 | struct 7 | (* This is basically Test_pmap, but specialized for MkMap(Int) *) 8 | module Map = MkMap (BatInt) 9 | 10 | let print_enum out enum = 11 | BatEnum.print begin 12 | fun out (c, _) -> 13 | BatPrintf.fprintf out "%d" c 14 | end out enum 15 | 16 | let assert_equal_enums enum_1 enum_2 = 17 | match BatEnum.compare compare (enum_1 ()) (enum_2 ()) with 18 | | 0 -> (* pass *) () 19 | | _ -> 20 | assert_failure 21 | (BatPrintf.sprintf2 "Expected %a, got %a" 22 | print_enum (enum_1 ()) print_enum (enum_2 ())) 23 | 24 | let assert_equal_maps map_1 map_2 = 25 | let enum_1 () = Map.enum map_1 in 26 | let enum_2 () = Map.enum map_2 in 27 | assert_equal_enums enum_1 enum_2 28 | 29 | let gen_map state bound count = 30 | let keys = BatEnum.take count (State.enum_int state bound) in 31 | Map.of_enum (BatEnum.map (fun x -> (x, x)) keys) 32 | 33 | let test_traversal_order () = 34 | let init = State.make [|0|] in 35 | let map = gen_map init 10 50 in 36 | let enum_1 () = Map.enum map 37 | and enum_2 () = 38 | let list = BatRefList.empty () in 39 | Map.iter (fun k v -> BatRefList.push list (k, v)) map; 40 | BatRefList.backwards list 41 | in 42 | assert_equal_enums enum_1 enum_2 43 | 44 | let tests = [ 45 | "traversal order iter vs. enum" >:: test_traversal_order ; 46 | ] 47 | end 48 | 49 | let tests = 50 | let module MT1 = MkTest (BatMap.Make) in 51 | let mt1_tests = "Map.Make" >::: MT1.tests in 52 | let module MT2 = MkTest (BatSplay.Map) in 53 | let mt2_tests = "Splay.Make" >::: MT2.tests in 54 | "Generic Map tests" >::: [ 55 | mt1_tests ; 56 | mt2_tests ; 57 | ] 58 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all clean install uninstall reinstall test doc 2 | 3 | all: 4 | dune build @all 5 | 6 | clean: 7 | dune clean 8 | 9 | install: 10 | dune build @install 11 | dune install 12 | 13 | uninstall: 14 | dune uninstall 15 | 16 | test: 17 | dune runtest 18 | 19 | doc: 20 | dune build @all 21 | dune build @doc 22 | 23 | test_install: 24 | ./scripts/test_install.sh 25 | 26 | reinstall: 27 | dune uninstall 28 | dune build @install 29 | dune install 30 | 31 | 32 | ############################################################################### 33 | # BENCHMARK SUITE 34 | ############################################################################### 35 | 36 | bench: 37 | $(OCAMLBUILD) $(OCAMLBUILDFLAGS) $(TARGETS) $(BENCH_TARGETS) 38 | $(RM) bench.log 39 | $(foreach BENCH, $(BENCH_TARGETS), _build/$(BENCH) | tee -a bench.log; ) 40 | @echo "Benchmarking results are written to bench.log" 41 | 42 | 43 | ############################################################################### 44 | # PREPARING RELEASE FILES 45 | ############################################################################### 46 | 47 | release: 48 | $(MAKE) clean 49 | git stash save "stashing local modifications before release" 50 | $(MAKE) release-cleaned 51 | 52 | # assumes irreproachably pristine working directory 53 | release-cleaned: doc test-native 54 | git archive --format=tar --prefix=batteries-$(VERSION)/ HEAD \ 55 | | gzip -9 > batteries-$(VERSION).tar.gz 56 | 57 | # uploads the current documentation to github hdoc2/ directory 58 | upload-docs: 59 | make doc && \ 60 | rm -rf /tmp/batteries.docdir && \ 61 | cp -a _build/batteries.docdir /tmp/ && \ 62 | git checkout gh-pages && \ 63 | rm -f hdoc2/*.html && \ 64 | cp /tmp/batteries.docdir/*.html hdoc2/ && \ 65 | git add hdoc2/*.html && \ 66 | git commit hdoc2 -m "Update ocamldoc to latest release" && \ 67 | git push origin gh-pages && \ 68 | git checkout master 69 | -------------------------------------------------------------------------------- /examples/benchmark/Makefile: -------------------------------------------------------------------------------- 1 | TESTS:=nth map folr map2 append flatten filter1 filter2 mapx folrx 2 | OPTS:=--max-i 10_000_000 3 | 4 | all: t_enum.byte 5 | 6 | t_enum.byte t_enum.native: t_enum.ml 7 | ocamlbuild t_enum.byte t_enum.native 8 | 9 | pngs: $(addsuffix .png, $(TESTS)) 10 | 11 | t_list.byte t_list.native: t_list.ml 12 | ocamlbuild t_list.byte t_list.native 13 | 14 | %.gallium_byte: t_list.byte 15 | #The following doesn't succeed for large I -- not tail-recursive 16 | - ./t_list.byte $(OPTS) -g $(basename $@) > $@ 17 | 18 | %.extlib_byte: t_list.byte 19 | ./t_list.byte $(OPTS) -e $(basename $@) > $@ 20 | 21 | %.blue_byte: t_list.byte 22 | ./t_list.byte $(OPTS) -b $(basename $@) > $@ 23 | 24 | %.core_byte: t_list.byte 25 | ./t_list.byte $(OPTS) -c $(basename $@) > $@ 26 | 27 | %.gallium_native: t_list.native 28 | #The following doesn't succeed for large I -- not tail-recursive 29 | - ./t_list.native $(OPTS) -g $(basename $@) > $@ 30 | 31 | %.extlib_native: t_list.native 32 | ./t_list.native $(OPTS) -e $(basename $@) > $@ 33 | 34 | %.blue_native: t_list.native 35 | ./t_list.native $(OPTS) -b $(basename $@) > $@ 36 | 37 | %.core_native: t_list.native 38 | ./t_list.native $(OPTS) -c $(basename $@) > $@ 39 | 40 | %.png: %.gallium_byte %.extlib_byte %.blue_byte %.core_byte %.gallium_native %.extlib_native %.blue_native %.core_native 41 | TEST=$(basename $@) 42 | echo "set logscale x; set logscale y; set terminal png; set xlabel \"List Length\"; set ylabel \"List-operations per second\"; set output \"$@\"; plot \"$(basename $@).gallium_byte\" w lp, \"$(basename $@).extlib_byte\" w lp, \"$(basename $@).blue_byte\" w lp, \"$(basename $@).core_byte\" w lp, \"$(basename $@).gallium_native\" w lp, \"$(basename $@).extlib_native\" w lp, \"$(basename $@).blue_native\" w lp, \"$(basename $@).core_native\" w lp" | gnuplot 43 | 44 | t_byte: $(addsuffix .gallium_byte, $(TESTS)) $(addsuffix .extlib_byte, $(TESTS)) 45 | 46 | clean: 47 | ocamlbuild -clean 48 | - rm *.*_byte *.*_native 49 | - rm *.png -------------------------------------------------------------------------------- /testsuite/test_mappable.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | (* The purpose of this test file is to test properties that should be 4 | verified by all instances of a given interface, here 5 | BatInterfaces.Mappable. 6 | 7 | It is very minimal for now : it only check for one property, and 8 | only a few of the Mappable modules (it is actually a regression 9 | test for a very specific bug). New properties will be added, and 10 | hopefully they will be verified against all Mappable modules. 11 | *) 12 | 13 | module TestMappable 14 | (M : sig 15 | include BatEnum.Enumerable 16 | 17 | include BatInterfaces.Mappable 18 | with type 'a mappable = 'a enumerable 19 | end) 20 | = 21 | struct 22 | (* The property we test is that the order in which the [map] 23 | function traverse the structure (applying a given function on 24 | each element) is the same as the order of the [enum] function of 25 | the module (the order in which the elements are produced in the 26 | enumeration). 27 | *) 28 | let test_map_evaluation_order printer t = 29 | let elems_in_enum_order = BatList.of_enum (M.enum t) in 30 | let elems_in_map_order = 31 | let li = ref [] in 32 | ignore (M.map (fun x -> li := x :: !li) t); 33 | List.rev !li in 34 | assert_equal ~printer:(BatIO.to_string (BatList.print printer)) 35 | elems_in_enum_order 36 | elems_in_map_order 37 | end 38 | 39 | let test_list_mappable () = 40 | let module T = TestMappable(BatList) in 41 | T.test_map_evaluation_order BatInt.print [1; 2; 3] 42 | 43 | let test_array_mappable () = 44 | let module T = TestMappable(BatArray) in 45 | T.test_map_evaluation_order BatInt.print [|1; 2; 3|] 46 | (* 47 | let test_pair_mappable () = 48 | let module T = TestMappable(BatTuple.Tuple2) in 49 | T.test_map_evaluation_order BatInt.print (1, 2) 50 | *) 51 | 52 | let tests = "Mappable" >::: [ 53 | "Array" >:: test_array_mappable; 54 | "List" >:: test_list_mappable; 55 | (* "Pair" >:: test_pair_mappable;*) 56 | ] 57 | -------------------------------------------------------------------------------- /toplevel/batteriesHelp.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Batteries_help - Calling the help system from the toplevel 3 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** Tools for reading the documentation from the toplevel 22 | 23 | All these tools are invoked automatically by the Batteries 24 | Toplevel. They are provided here if you wish to integrate them 25 | into your own toplevel. 26 | 27 | @author David Teller 28 | *) 29 | 30 | type kinds = 31 | | Values 32 | | Types 33 | | Topics 34 | | Modules 35 | | Exns 36 | | Modtypes 37 | | Classes 38 | | Methods 39 | | Attributes 40 | | Objtypes 41 | 42 | val init : unit -> unit 43 | (** Proceed to initialization. 44 | 45 | This function loads the primary help files and registers the 46 | toplevel directives. 47 | 48 | If you integrate the on-line help system into your toplevel, you 49 | must call this function before any of the other functions of this 50 | module. *) 51 | 52 | val help : unit -> unit 53 | (** [help ()] opens the tutorial.*) 54 | 55 | val man : string -> unit 56 | (** [man "something"] opens the help about subject ["something"]. 57 | *) 58 | 59 | -------------------------------------------------------------------------------- /src/batMarshal.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatMarshal - Extended marshaling operations 3 | * Copyright (C) 1997 Xavier Leroy 4 | * 2008 David Teller 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | 23 | include Marshal 24 | 25 | ##V<4.2##let from_bytes = from_string 26 | ##V<4.2##external to_bytes : 27 | ##V<4.2## 'a -> extern_flags list -> Bytes.t = "caml_output_value_to_string" 28 | 29 | let output out ?(sharing=true) ?(closures=false) v = 30 | let flags = match sharing, closures with 31 | | true, false -> [] 32 | | true, true -> [Closures] 33 | | false, false -> [No_sharing] 34 | | false, true -> [No_sharing; Closures] 35 | in 36 | let buf = to_string v flags in 37 | BatInnerIO.nwrite out buf 38 | 39 | let input inp = 40 | let header = Bytes.create header_size in 41 | let read = BatInnerIO.really_input inp header 0 header_size in 42 | assert (read = header_size); 43 | let data_size = data_size header 0 in 44 | let buf = Bytes.extend header 0 data_size in 45 | let read = BatInnerIO.really_input inp buf header_size data_size in 46 | assert (read = data_size); 47 | from_bytes buf 0 48 | 49 | let from_channel = input 50 | 51 | let to_channel out v flags = 52 | BatInnerIO.nwrite out (to_string v flags) 53 | 54 | 55 | -------------------------------------------------------------------------------- /testsuite/test_num.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatNum 3 | 4 | let tests = "Num" >::: [ 5 | "of_float" >::: [ 6 | "zero" >:: begin function () -> 7 | assert_equal ~cmp:(=) ~printer:to_string zero (of_float 0.) 8 | end; 9 | "numbers" >:: begin function () -> 10 | Array.iter begin function f -> 11 | assert_equal ~printer:BatFloat.to_string f 12 | (to_float (of_float f)) 13 | end 14 | [|2.5; 1.0; 0.5; -0.5; -1.0; -2.5|] 15 | end; 16 | "infinity/nan" >::: 17 | (* set/reset pair for (re)setting the error_when_null_denominator state. 18 | * A stack is used instead of simple ref to make calls nestable. *) 19 | let (set, reset) = 20 | let saved_state = Stack.create () in 21 | begin fun state () -> 22 | Stack.push 23 | (Arith_status.get_error_when_null_denominator ()) 24 | saved_state; 25 | Arith_status.set_error_when_null_denominator state; 26 | end, 27 | begin fun () -> 28 | Arith_status.set_error_when_null_denominator 29 | (Stack.pop saved_state) 30 | end 31 | in 32 | let test () = 33 | Array.iter 34 | (* f is float, n/d are expected nominator and denominator *) 35 | begin fun (f, (n,d)) -> 36 | if Arith_status.get_error_when_null_denominator () 37 | then 38 | (* expect error *) 39 | assert_raises 40 | (Failure "create_ratio infinite or undefined rational number") 41 | (fun () -> ignore (of_float f)) 42 | else 43 | (* expect result *) 44 | assert_equal ~cmp:equal ~printer:to_string 45 | (div n d) 46 | (of_float f) 47 | end 48 | (* values to test *) 49 | [| infinity, (one,zero); neg_infinity, (neg one,zero); nan, (zero,zero) |] 50 | in 51 | [ 52 | (* allow null denominator *) 53 | "allow_null_denom" >:: bracket (set false) test reset; 54 | (* disallow null denominator *) 55 | "forbid_null_denom" >:: bracket (set true) test reset; 56 | ] 57 | ] 58 | ] 59 | -------------------------------------------------------------------------------- /testsuite/test_print.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open Gc 3 | 4 | let few_tests = 10 5 | let many_tests= 100000 6 | (* (*For comparison, not part of Batteries.*) 7 | let run_legacy number_of_runs = 8 | begin 9 | Gc.full_major (); 10 | let devnull = Legacy.Pervasives.open_out "/dev/null" in 11 | foreach (1 -- number_of_runs) (fun _ -> 12 | Legacy.Printf.fprintf devnull "%a%!" (fun ch () -> Legacy.Printf.fprintf ch "Hello, world!") () 13 | ); 14 | Legacy.Pervasives.close_out devnull; 15 | Gc.full_major (); 16 | (Gc.stat()).live_words 17 | end 18 | 19 | let test_leak_legacy () = 20 | let words_few = run_legacy few_tests in 21 | let words_many= run_legacy many_tests in 22 | if words_few < words_many then assert_failure (Printf.sprintf "Memory use grew by %d" (words_many - words_few)) 23 | *) 24 | open Printf 25 | let run_oldstyle number_of_runs = 26 | Gc.full_major (); 27 | foreach (1 -- number_of_runs) (fun _ -> 28 | fprintf stdnull "%a%!" (fun ch () -> fprintf ch "Hello, world!") () 29 | ); 30 | Gc.full_major (); 31 | (Gc.stat()).live_words 32 | 33 | let test_leak_oldstyle () = 34 | let words_few = run_oldstyle few_tests in 35 | let words_many= run_oldstyle many_tests in 36 | if words_few < words_many then assert_failure (Printf.sprintf "Memory use grew by %d" (words_many - words_few)) 37 | 38 | open Print 39 | let run_newstyle number_of_runs = 40 | Gc.full_major (); 41 | let printer_hello k () = k (fun ch -> fprintf ch p"Hello, world!") in 42 | foreach (1 -- number_of_runs) (fun _ -> 43 | fprintf stdnull p"{%hello}%!" () 44 | ); 45 | Gc.full_major (); 46 | (Gc.stat()).live_words 47 | 48 | let test_leak_newstyle () = 49 | let words_few = run_newstyle few_tests in 50 | let words_many= run_newstyle many_tests in 51 | if words_few < words_many then assert_failure (Printf.sprintf "Memory use grew by %d" (words_many - words_few)) 52 | 53 | 54 | let tests = "Print" >::: [ 55 | (* "Legacy printing memory leak" >:: test_leak_legacy ;*) 56 | "Old-style printing memory leak" >:: test_leak_oldstyle ; 57 | "New-style printing memory leak" >:: test_leak_newstyle 58 | ] 59 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | ben kuin ben le kuin 2 | Gabriel Scherer bluestorm 3 | Gabriel Scherer bluestorm 4 | Cedric Cellier Cedric Cellier 5 | Cedric Cellier Cedric Cellier 6 | Cedric Cellier cedric cellier 7 | Dawid Toton Dawid Toton 8 | Eric Norige Edgar Friendly 9 | Gabriel Scherer Gabriel Scherer 10 | Gabriel Scherer gasche 11 | Hezekiah M. Carty Hezekiah M. Carty 12 | Hezekiah M. Carty Hezekiah M. Carty 13 | Jérémie Dimino Jérémie Dimino 14 | Justus Matthiesen Justus Matthiesen 15 | Kaustuv Chaudhuri Kaustuv Chaudhuri 16 | Michael Ekstrand Michael D Ekstrand 17 | Michael Ekstrand Michael Ekstrand 18 | Philippe Veber pveber 19 | Philippe Veber Philippe 20 | Eric Norige thelema 21 | David Teller Yoric 22 | David Teller yoric 23 | David Teller Yoric 24 | David Teller David Teller 25 | Erkki Seppälä Erkki Seppala 26 | Erkki Seppälä Erkki Seppala 27 | Francois Berenger 28 | Francois Berenger Francois BERENGER 29 | -------------------------------------------------------------------------------- /examples/benchmark/t_strstr.ml: -------------------------------------------------------------------------------- 1 | open Bigarray 2 | 3 | 4 | let stride = 8 (* bytes *) 5 | let ba_cat = int64 6 | 7 | let blit_string_to_ba s = 8 | let ba = Array1.create ba_cat c_layout ((String.length s + stride - 1) / stride) in 9 | let s' = (Obj.magic (Obj.field (Obj.repr ba) 1) : string) in 10 | for i = 0 to String.length s - 1 do 11 | String.unsafe_set s' i (String.unsafe_get s i); 12 | done; 13 | ba 14 | 15 | let build_srch_ht n_ba = 16 | let len = Array1.dim n_ba in 17 | let ht = Hashtbl.create len in 18 | for i = 0 to len - 1 do 19 | Hashtbl.add ht (Array1.get n_ba i) i 20 | done; 21 | ht 22 | 23 | let volnit ~n_ba = 24 | let ht = build_srch_ht n_ba in 25 | let ret = ref [] in 26 | fun ~hs_ba verify -> 27 | for i = 0 to Array1.dim hs_ba - 1 do 28 | try 29 | let off = Hashtbl.find ht (Array1.unsafe_get hs_ba i) in 30 | let srch_off = i * stride - off in 31 | if verify ~off:srch_off then 32 | ret := srch_off :: !ret 33 | with 34 | Not_found -> () 35 | done; 36 | !ret 37 | 38 | 39 | let vol n = 40 | let s = volnit ~n_ba:(blit_string_to_ba n) in 41 | fun hs -> s ~hs_ba:(blit_string_to_ba hs) (fun ~off -> String.sub hs off (String.length n) = n) 42 | 43 | open Batteries 44 | 45 | let rec find_all_aux n hs last acc = 46 | match 47 | try Some (String.find_from hs (last+1) n) with Not_found -> None 48 | with 49 | | Some i -> find_all_aux n hs i (last::acc) 50 | | None -> List.rev (last::acc) 51 | 52 | let find_all n hs = 53 | try 54 | let i0 = String.find hs n in 55 | find_all_aux n hs i0 [] 56 | with Not_found -> [] 57 | 58 | let n1 = "abcde" 59 | let hs1 = "abcabcabdeabcdeabbaab" 60 | 61 | let na1 = blit_string_to_ba n1 62 | let hsa1 = blit_string_to_ba hs1 63 | 64 | let test_vol = 65 | let v = vol n1 in 66 | fun () -> v hs1 67 | 68 | let test_vol_ba = 69 | let v = volnit ~n_ba:na1 in 70 | fun () -> v ~hs_ba:hsa1 (fun ~off -> String.sub hs1 off (String.length n1) = n1) 71 | 72 | let test_bf () = find_all n1 hs1 73 | 74 | let tests = 75 | [ "vol", test_vol , (); 76 | "vol_ba", test_vol_ba, (); 77 | "batfind", test_bf, (); 78 | ] 79 | 80 | open Benchmark 81 | 82 | let () = 83 | latencyN 1_000_000L tests |> tabulate 84 | -------------------------------------------------------------------------------- /src/batUref.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Uref -- unifiable references 3 | * Copyright (C) 2011 Batteries Included Development Team 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** Unifiable references using destructive union-find *) 22 | 23 | type 'a uref 24 | (** A [t uref] is a reference to a cell that contains a 25 | value of type [t]. *) 26 | 27 | type 'a t = 'a uref 28 | (** A synonym for convenience *) 29 | 30 | val uref : 'a -> 'a uref 31 | (** [uref x] allocates a new uref and places the value [x] in it. *) 32 | 33 | val uget : 'a uref -> 'a 34 | (** [uget ur] returns the value stored in the uref [ur]. *) 35 | 36 | val uset : 'a uref -> 'a -> unit 37 | (** [uset ur x] updates the contents of [ur] with [x]. *) 38 | 39 | val unite : ?sel:('a -> 'a -> 'a) -> 'a uref -> 'a uref -> unit 40 | (** [unite ~sel ur1 ur2] unites the urefs [ur1] and [ur2], selecting 41 | the result of [sel (uget ur1) (uget ur2)] for the contents of 42 | the resulting united uref. After this operation, [uget ur1 == 43 | uget ur2]. By default, [sel] is [fun x _y -> x]. *) 44 | 45 | val equal : 'a uref -> 'a uref -> bool 46 | (** [equal ur1 ur2] returns [true] iff [ur1] and [ur2] are equal 47 | urefs, either because they are physically the same or because 48 | they have been {!unite}d. *) 49 | 50 | (** {1 Printing} *) 51 | 52 | val print : ('a, 'b) BatIO.printer -> ('a uref, 'b) BatIO.printer 53 | (** Print the uref. *) 54 | -------------------------------------------------------------------------------- /examples/euler/euler013.ml: -------------------------------------------------------------------------------- 1 | open Batteries 2 | let data = [ 3 | 37107287533902; 4 | 46376937677490; 5 | 74324986199524; 6 | 91942213363574; 7 | 23067588207539; 8 | 89261670696623; 9 | 28112879812849; 10 | 44274228917432; 11 | 47451445736001; 12 | 70386486105843; 13 | 62176457141856; 14 | 64906352462741; 15 | 92575867718337; 16 | 58203565325359; 17 | 80181199384826; 18 | 35398664372827; 19 | 86515506006295; 20 | 71693888707715; 21 | 54370070576826; 22 | 53282654108756; 23 | 36123272525000; 24 | 45876576172410; 25 | 17423706905851; 26 | 81142660418086; 27 | 51934325451728; 28 | 62467221648435; 29 | 15732444386908; 30 | 55037687525678; 31 | 18336384825330; 32 | 80386287592878; 33 | 78182833757993; 34 | 16726320100436; 35 | 48403098129077; 36 | 87086987551392; 37 | 59959406895756; 38 | 69793950679652; 39 | 41052684708299; 40 | 65378607361501; 41 | 35829035317434; 42 | 94953759765105; 43 | 88902802571733; 44 | 25267680276078; 45 | 36270218540497; 46 | 24074486908231; 47 | 91430288197103; 48 | 34413065578016; 49 | 23053081172816; 50 | 11487696932154; 51 | 63783299490636; 52 | 67720186971698; 53 | 95548255300263; 54 | 76085327132285; 55 | 37774242535411; 56 | 23701913275725; 57 | 29798860272258; 58 | 18495701454879; 59 | 38298203783031; 60 | 34829543829199; 61 | 40957953066405; 62 | 29746152185502; 63 | 41698116222072; 64 | 62467957194401; 65 | 23189706772547; 66 | 86188088225875; 67 | 11306739708304; 68 | 82959174767140; 69 | 97623331044818; 70 | 42846280183517; 71 | 55121603546981; 72 | 32238195734329; 73 | 75506164965184; 74 | 62177842752192; 75 | 32924185707147; 76 | 99518671430235; 77 | 73267460800591; 78 | 76841822524674; 79 | 97142617910342; 80 | 87783646182799; 81 | 10848802521674; 82 | 71329612474782; 83 | 62184073572399; 84 | 66627891981488; 85 | 60661826293682; 86 | 85786944089552; 87 | 66024396409905; 88 | 64913982680032; 89 | 16730939319872; 90 | 94809377245048; 91 | 78639167021187; 92 | 15368713711936; 93 | 40789923115535; 94 | 44889911501440; 95 | 41503128880339; 96 | 81234880673210; 97 | 82616570773948; 98 | 22918802058777; 99 | 77158542502016; 100 | 72107838435069; 101 | 20849603980134; 102 | 53503534226472; ] 103 | 104 | let () = List.reduce (+) data |> print_int; print_newline () 105 | (* fix: print only the first 10 characters *) 106 | -------------------------------------------------------------------------------- /testsuite/test_bounded.ml: -------------------------------------------------------------------------------- 1 | open BatPervasives 2 | module R = BatRandom 3 | module U = OUnit 4 | 5 | module Int10_base = struct 6 | type base_t = int 7 | type t = int option 8 | let bounds = `c 1, `c 10 9 | let bounded = BatBounded.opt_of_ord BatInt.ord 10 | let base_of_t x = x 11 | let base_of_t_exn x = BatOption.get x 12 | module Infix = BatInt.Infix 13 | end 14 | 15 | (** Only accept integers between 1 and 10, inclusive *) 16 | module Int10 = BatBounded.MakeNumeric(Int10_base) 17 | 18 | module Float10_base = struct 19 | type base_t = float 20 | type t = float option 21 | let bounds = `o 1.0, `o 10.0 22 | let bounded = BatBounded.opt_of_ord BatFloat.ord 23 | let base_of_t x = x 24 | let base_of_t_exn x = BatOption.get x 25 | module Infix = BatFloat.Infix 26 | end 27 | 28 | (** Only accept floating point values between 1 and 10, exclusive *) 29 | module Float10 = BatBounded.MakeNumeric(Float10_base) 30 | 31 | let assert_make (type s) m to_string (xs : s list) = 32 | let module B = 33 | ( 34 | val m : 35 | BatBounded.NumericSig with type base_u = s and type u = s option 36 | ) 37 | in 38 | let min_bound, max_bound = B.bounds in 39 | let min_check = 40 | match min_bound with 41 | | `o a -> (fun x -> x > a) 42 | | `c a -> (fun x -> x >= a) 43 | | `u -> (const true) 44 | in 45 | let max_check = 46 | match max_bound with 47 | | `o a -> (fun x -> x < a) 48 | | `c a -> (fun x -> x <= a) 49 | | `u -> (const true) 50 | in 51 | List.iter ( 52 | fun x -> 53 | let printer b = Printf.sprintf "%s (%b)" (to_string x) b in 54 | U.assert_equal ~printer (max_check x && min_check x) (BatOption.is_some ((B.make %> B.extract) x)) 55 | ) xs; 56 | () 57 | 58 | let test_make () = 59 | let xs = BatList.init 100 identity in 60 | let m = 61 | (module Int10 : BatBounded.NumericSig with type base_u = int and type u = int option) 62 | in 63 | assert_make m string_of_int xs; 64 | let xs = BatList.init 110 (fun x -> float_of_int x /. 10.0) in 65 | let m = 66 | (module Float10 : BatBounded.NumericSig with type base_u = float and type u = float option) 67 | in 68 | assert_make m string_of_float xs 69 | 70 | let (>::), (>:::) = U.(>::), U.(>:::) 71 | 72 | let tests = "Bounded" >::: [ 73 | "value creation" >:: test_make 74 | ] 75 | -------------------------------------------------------------------------------- /testsuite/test_pmap.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatRandom 3 | open BatPervasives 4 | 5 | let print_enum out enum = 6 | BatEnum.print (fun out (c, _) -> BatPrintf.fprintf out "%d" c) out enum 7 | 8 | let assert_equal_enums enum_1 enum_2 = 9 | match BatEnum.compare compare (enum_1 ()) (enum_2 ()) with 10 | | 0 -> (* pass *) () 11 | | _ -> 12 | assert_failure 13 | (BatPrintf.sprintf2 "Expected %a, got %a" 14 | print_enum (enum_1 ()) print_enum (enum_2 ())) 15 | 16 | let assert_equal_maps map_1 map_2 = 17 | let enum_1 () = BatPMap.enum map_1 in 18 | let enum_2 () = BatPMap.enum map_2 in 19 | assert_equal_enums enum_1 enum_2 20 | 21 | let gen_map state bound count = 22 | let keys = BatEnum.take count (State.enum_int state bound) in 23 | BatPMap.of_enum (BatEnum.map (fun x -> (x,x)) keys) 24 | 25 | let test_traversal_order () = 26 | let init = State.make [|0|] in 27 | let map = gen_map init 10 50 in 28 | let enum_1 () = BatPMap.enum map 29 | and enum_2 () = 30 | let list = BatRefList.empty () in 31 | BatPMap.iter (fun k v -> BatRefList.push list (k, v)) map; 32 | BatRefList.backwards list 33 | in 34 | assert_equal_enums enum_1 enum_2 35 | 36 | let test_split () = 37 | let do_test map v = 38 | let m1, vo, m2 = BatPMap.split v map in 39 | assert_equal_maps m1 (BatPMap.filteri (fun k _ -> k < v) map); 40 | assert_equal_maps m2 (BatPMap.filteri (fun k _ -> k > v) map); 41 | assert_equal vo (if BatPMap.mem v map then Some v else None) 42 | in 43 | let init = State.make [|0|] in 44 | for i = 0 to 50 do 45 | let bound = 40 in 46 | let count = i * 5 in 47 | do_test (gen_map init bound count) (State.int init bound) 48 | done 49 | 50 | let test_multimap_empty_assoc_lists () = 51 | let module M = BatMultiPMap in 52 | let map = 53 | M.add 0 "foo" M.empty |> M.add 0 "bar" |> M.add 0 "sna" |> 54 | M.remove 0 "foo" |> M.remove 0 "bar" |> M.remove 0 "sna" 55 | in 56 | if M.mem 0 map then 57 | assert_failure 58 | (Printf.sprintf "map[0] should be empty but contains %d bindings\n" 59 | (BatPSet.cardinal (M.find 0 map))) 60 | 61 | let tests = "PMap" >::: [ 62 | "traversal order iter vs. enum" >:: test_traversal_order; 63 | "split" >:: test_split; 64 | "MultiPMap: removing empty association lists" >:: test_multimap_empty_assoc_lists; 65 | ] 66 | -------------------------------------------------------------------------------- /src/batGc.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatGC - Extended GC operations 3 | * Copyright (C) 1996 Damien Doligez 4 | * 2008 David Teller, LIFO, Universite d'Orleans 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open BatPrintf 23 | include Gc 24 | 25 | let print_stat c = (* copied from original module *) 26 | let st = stat () in 27 | fprintf c "minor_collections: %d\n" st.minor_collections; 28 | fprintf c "major_collections: %d\n" st.major_collections; 29 | fprintf c "compactions: %d\n" st.compactions; 30 | fprintf c "\n"; 31 | let l1 = String.length (sprintf "%.0f" st.minor_words) in 32 | fprintf c "minor_words: %*.0f\n" l1 st.minor_words; 33 | fprintf c "promoted_words: %*.0f\n" l1 st.promoted_words; 34 | fprintf c "major_words: %*.0f\n" l1 st.major_words; 35 | fprintf c "\n"; 36 | let l2 = String.length (sprintf "%d" st.top_heap_words) in 37 | fprintf c "top_heap_words: %*d\n" l2 st.top_heap_words; 38 | fprintf c "heap_words: %*d\n" l2 st.heap_words; 39 | fprintf c "live_words: %*d\n" l2 st.live_words; 40 | fprintf c "free_words: %*d\n" l2 st.free_words; 41 | fprintf c "largest_free: %*d\n" l2 st.largest_free; 42 | fprintf c "fragments: %*d\n" l2 st.fragments; 43 | fprintf c "\n"; 44 | fprintf c "live_blocks: %d\n" st.live_blocks; 45 | fprintf c "free_blocks: %d\n" st.free_blocks; 46 | fprintf c "heap_chunks: %d\n" st.heap_chunks 47 | 48 | (*$T print_stat 49 | (IO.output_string () |> tap print_stat |> IO.close_out |> String.split_on_string ~by:"\n" |> List.length) = 19 50 | *) 51 | -------------------------------------------------------------------------------- /examples/euler/euler011.ml: -------------------------------------------------------------------------------- 1 | let arr = 2 | [|08; 02; 22; 97; 38; 15; 00; 40; 00; 75; 04; 05; 07; 78; 52; 12; 50; 77; 91; 08; 3 | 49; 49; 99; 40; 17; 81; 18; 57; 60; 87; 17; 40; 98; 43; 69; 48; 04; 56; 62; 00; 4 | 81; 49; 31; 73; 55; 79; 14; 29; 93; 71; 40; 67; 53; 88; 30; 03; 49; 13; 36; 65; 5 | 52; 70; 95; 23; 04; 60; 11; 42; 69; 24; 68; 56; 01; 32; 56; 71; 37; 02; 36; 91; 6 | 22; 31; 16; 71; 51; 67; 63; 89; 41; 92; 36; 54; 22; 40; 40; 28; 66; 33; 13; 80; 7 | 24; 47; 32; 60; 99; 03; 45; 02; 44; 75; 33; 53; 78; 36; 84; 20; 35; 17; 12; 50; 8 | 32; 98; 81; 28; 64; 23; 67; 10; 26; 38; 40; 67; 59; 54; 70; 66; 18; 38; 64; 70; 9 | 67; 26; 20; 68; 02; 62; 12; 20; 95; 63; 94; 39; 63; 08; 40; 91; 66; 49; 94; 21; 10 | 24; 55; 58; 05; 66; 73; 99; 26; 97; 17; 78; 78; 96; 83; 14; 88; 34; 89; 63; 72; 11 | 21; 36; 23; 09; 75; 00; 76; 44; 20; 45; 35; 14; 00; 61; 33; 97; 34; 31; 33; 95; 12 | 78; 17; 53; 28; 22; 75; 31; 67; 15; 94; 03; 80; 04; 62; 16; 14; 09; 53; 56; 92; 13 | 16; 39; 05; 42; 96; 35; 31; 47; 55; 58; 88; 24; 00; 17; 54; 24; 36; 29; 85; 57; 14 | 86; 56; 00; 48; 35; 71; 89; 07; 05; 44; 44; 37; 44; 60; 21; 58; 51; 54; 17; 58; 15 | 19; 80; 81; 68; 05; 94; 47; 69; 28; 73; 92; 13; 86; 52; 17; 77; 04; 89; 55; 40; 16 | 04; 52; 08; 83; 97; 35; 99; 16; 07; 97; 57; 32; 16; 26; 26; 79; 33; 27; 98; 66; 17 | 88; 36; 68; 87; 57; 62; 20; 72; 03; 46; 33; 67; 46; 55; 12; 32; 63; 93; 53; 69; 18 | 04; 42; 16; 73; 38; 25; 39; 11; 24; 94; 72; 18; 08; 46; 29; 32; 40; 62; 76; 36; 19 | 20; 69; 36; 41; 72; 30; 23; 88; 34; 62; 99; 69; 82; 67; 59; 85; 74; 04; 36; 16; 20 | 20; 73; 35; 29; 78; 31; 90; 01; 74; 31; 49; 71; 48; 86; 81; 16; 23; 57; 05; 54; 21 | 01; 70; 54; 71; 83; 51; 54; 69; 16; 92; 33; 48; 61; 43; 52; 01; 89; 19; 67; 48; 22 | |] 23 | 24 | let get r c = arr.(r * 20 + c) 25 | 26 | 27 | let best_lr = 28 | let best = ref 1 in 29 | let test f = best := max !best (f 0 * f 1 * f 2 * f 3) in 30 | for row = 0 to 19 do 31 | for col = 0 to 19 do 32 | let lr i = get row (col + i) 33 | and tb i = get (row+i) col 34 | and d1 i = get (row+i) (col+i) 35 | and d2 i = get (row-i) (col+i) in 36 | if col + 3 <= 19 then test lr; 37 | if row + 3 <= 19 then test tb; 38 | if (row + 3 <= 19 && col + 3 <= 19) then test d1; 39 | if (row >= 3 && col >= 3) then test d2; 40 | done 41 | done; 42 | print_int !best; print_newline () 43 | -------------------------------------------------------------------------------- /src/batEither.ml: -------------------------------------------------------------------------------- 1 | (**************************************************************************) 2 | (* *) 3 | (* OCaml *) 4 | (* *) 5 | (* Gabriel Scherer, projet Parsifal, INRIA Saclay *) 6 | (* *) 7 | (* Copyright 2019 Institut National de Recherche en Informatique et *) 8 | (* en Automatique. *) 9 | (* *) 10 | (* All rights reserved. This file is distributed under the terms of *) 11 | (* the GNU Lesser General Public License version 2.1, with the *) 12 | (* special exception on linking described in the file LICENSE. *) 13 | (* *) 14 | (**************************************************************************) 15 | 16 | type ('a, 'b) t = 17 | ##V>=4.12## ('a, 'b) Stdlib.Either.t = 18 | Left of 'a | Right of 'b (**) 19 | 20 | let left v = Left v 21 | let right v = Right v 22 | 23 | let is_left = function 24 | | Left _ -> true 25 | | Right _ -> false 26 | 27 | let is_right = function 28 | | Left _ -> false 29 | | Right _ -> true 30 | 31 | let find_left = function 32 | | Left v -> Some v 33 | | Right _ -> None 34 | 35 | let find_right = function 36 | | Left _ -> None 37 | | Right v -> Some v 38 | 39 | let map_left f = function 40 | | Left v -> Left (f v) 41 | | Right _ as e -> e 42 | 43 | let map_right f = function 44 | | Left _ as e -> e 45 | | Right v -> Right (f v) 46 | 47 | let map ~left ~right = function 48 | | Left v -> Left (left v) 49 | | Right v -> Right (right v) 50 | 51 | let fold ~left ~right = function 52 | | Left v -> left v 53 | | Right v -> right v 54 | 55 | let iter = fold 56 | 57 | let for_all = fold 58 | 59 | let equal ~left ~right e1 e2 = match e1, e2 with 60 | | Left v1, Left v2 -> left v1 v2 61 | | Right v1, Right v2 -> right v1 v2 62 | | Left _, Right _ | Right _, Left _ -> false 63 | 64 | let compare ~left ~right e1 e2 = match e1, e2 with 65 | | Left v1, Left v2 -> left v1 v2 66 | | Right v1, Right v2 -> right v1 v2 67 | | Left _, Right _ -> (-1) 68 | | Right _, Left _ -> 1 69 | -------------------------------------------------------------------------------- /benchsuite/array_filter.ml: -------------------------------------------------------------------------------- 1 | let (|>) x f = f x 2 | 3 | let list_filter a p = 4 | Array.to_list a |> List.filter p |> Array.of_list 5 | 6 | open Array 7 | let new_filter xs p = 8 | let n = length xs in 9 | (* Use a bitset to store which elements will be in the final array. *) 10 | let bs = BatBitSet.create n in 11 | for i = 0 to n-1 do 12 | if p xs.(i) then BatBitSet.set bs i 13 | done; 14 | (* Allocate the final array and copy elements into it. *) 15 | let n' = BatBitSet.count bs in 16 | let j = ref 0 in 17 | init n' 18 | (fun _ -> match BatBitSet.next_set_bit bs !j with 19 | | Some i -> j := i+1; xs.(i) 20 | | None -> assert false (* not enough 1 bits - incorrect count? *) 21 | ) 22 | 23 | let old_filter xs p = 24 | let n = length xs in 25 | (* Use a bitset to store which elements will be in the final array. *) 26 | let bs = BatBitSet.create n in 27 | for i = 0 to n-1 do 28 | if p xs.(i) then BatBitSet.set bs i 29 | done; 30 | (* Allocate the final array and copy elements into it. *) 31 | let n' = BatBitSet.count bs in 32 | let j = ref 0 in 33 | let xs' = init n' 34 | (fun _ -> 35 | (* Find the next set bit in the BitSet. *) 36 | while not (BatBitSet.mem bs !j) do incr j done; 37 | let r = xs.(!j) in 38 | incr j; 39 | r) in 40 | xs' 41 | 42 | let classic_filter xs p = 43 | let n = length xs in 44 | if n = 0 then [||] else begin 45 | let bs = Array.init n (fun i -> p xs.(i)) in 46 | let size = ref 0 in 47 | for i = 0 to n - 1 do 48 | if bs.(i) then incr size 49 | done; 50 | let result = Array.make !size xs.(0) in 51 | let j = ref 0 in 52 | for i = 0 to n - 1 do 53 | if bs.(i) then begin 54 | result.(!j) <- xs.(i); 55 | incr j; 56 | end 57 | done; 58 | result 59 | end 60 | 61 | let input_gen n = Array.init (1000 * n) (fun x -> x) 62 | 63 | let m4 = fun x -> x mod 4 = 0 64 | let m5 = fun x -> x mod 5 = 0 65 | let m10 = fun x -> x mod 10 = 0 66 | 67 | let () = 68 | Bench.config.Bench.samples <- 1000; 69 | Bench.config.Bench.gc_between_tests <- true; 70 | Bench.bench_n ["list_filter", (fun a -> list_filter (input_gen a) m4); 71 | "old_filter", (fun a -> old_filter (input_gen a) m4); 72 | "new_filter", (fun a -> new_filter (input_gen a) m4); 73 | "classic_filter", (fun a -> new_filter (input_gen a) m4); 74 | ] 75 | |> Bench.summarize ~alpha:0.05 76 | -------------------------------------------------------------------------------- /FAQ: -------------------------------------------------------------------------------- 1 | *** FAQ for Batteries Included *** 2 | 3 | *** Common Problems *** 4 | 5 | **** "Error: Unbound module Batteries" 6 | 7 | Check that you're using ocamlfind with `-package batteries`, or `pkg(batteries)` 8 | in OCamlBuild _tags file to tell OCaml to make Batteries available to your code. 9 | 10 | *** General *** 11 | 12 | **** What is OCaml Batteries **** 13 | 14 | OCaml Batteries Included: a community-maintained foundation library for your OCaml projecs. 15 | 16 | 17 | **** What is it good for **** 18 | 19 | Batteries Included serves the following purposes: 20 | * define a standard set of libraries which may be 21 | expected on every compliant installation of OCaml 22 | * organize these libraries into a hierarchy of modules, 23 | with one source of documentation 24 | * provide a consistent API for otherwise independent 25 | libraries. 26 | 27 | *** Installation *** 28 | 29 | **** Errors **** 30 | 31 | ERROR: omake: Symbol `FamErrlist' has different size in shared object, consider re-linking 32 | 33 | This error is caused when using Gamin rather than FAM. Gamin is a 34 | binary-compatible replacement for libfam that does not use the 35 | system-wide monitor daemon. Most packages, however, are compiled and 36 | linked against libfam from the FAM package. They will work with Gamin 37 | without recompilation, but display the symbol size discrepancy 38 | warning. This error can safely be ignored. 39 | 40 | If you really want to get rid of the warning, on an Ubuntu based OS, 41 | run the following command: 42 | 43 | sudo apt-get install libfam0 44 | 45 | Note that FAM misbehaves in certain environments, notably AFS-based 46 | systems. 47 | 48 | 49 | *** Using Batteries *** 50 | 51 | In your source code, add [open Batteries]. When you've done this, you'll 52 | have access to the Batteries modules that extend stdlib modules as part of 53 | the stdlib modules. To access the original stdlib modules, use 54 | [Legacy.List], for example. Other [BatFoo] modules provided by batteries 55 | are available as simply [Foo]. 56 | 57 | **** Compiling with Ocamlbuild **** 58 | 59 | Copy build/myocamlbuild.ml into your source directory, and use: 60 | 61 | <*>: package(batteries) 62 | 63 | in your _tags file to enable batteries for all modules. 64 | 65 | **** Bare Findlib **** 66 | 67 | ocamlfind ocamlc -package batteries -linkpkg foo.ml -o foo 68 | 69 | **** OMake **** 70 | 71 | Add the following to your OMakefile: 72 | 73 | OCAMLPACKS[] += batteries 74 | -------------------------------------------------------------------------------- /benchsuite/bench_set_to_seq.ml: -------------------------------------------------------------------------------- 1 | (* cd .. && ocamlbuild -use-ocamlfind benchsuite/bench_set_to_seq.native && _build/benchsuite/bench_set_to_seq.native *) 2 | 3 | (* The purpose of this test is to compare different implementation of 4 | BatSet.to_seq. *) 5 | 6 | (* the type BatSet.t is abstract, 7 | we break the abstraction boundary locally to implement our versions outside the module. *) 8 | type 'a set = 9 | | Empty 10 | | Node of 'a set * 'a * 'a set * int 11 | external hide : 'a set -> 'a BatSet.t = "%identity" 12 | external reveal : 'a BatSet.t -> 'a set = "%identity" 13 | 14 | 15 | module TooStrict = struct 16 | let rec to_seq m = 17 | match m with 18 | | Empty -> BatSeq.nil 19 | | Node(l, v, r, _) -> 20 | BatSeq.append (to_seq l) (fun () -> BatSeq.Cons (v, to_seq r)) 21 | 22 | let to_seq s = to_seq (reveal s) 23 | end 24 | 25 | module Simple = struct 26 | let rec to_seq m = 27 | fun () -> 28 | match m with 29 | | Empty -> BatSeq.Nil 30 | | Node(l, v, r, _) -> 31 | BatSeq.append (to_seq l) (fun () -> BatSeq.Cons (v, to_seq r)) () 32 | 33 | let to_seq s = to_seq (reveal s) 34 | end 35 | 36 | module Enumeration = struct 37 | type 'a iter = E | C of 'a * 'a set * 'a iter 38 | 39 | let rec cons_iter s t = match s with 40 | | Empty -> t 41 | | Node (l, e, r, _) -> cons_iter l (C (e, r, t)) 42 | 43 | let to_seq s = 44 | let rec to_seq iter () = 45 | match iter with 46 | | E -> BatSeq.Nil 47 | | C (e, r, t) -> 48 | BatSeq.Cons (e, to_seq (cons_iter r t)) 49 | in 50 | to_seq (cons_iter s E) 51 | 52 | let to_seq s = to_seq (reveal s) 53 | end 54 | 55 | let test_input = 56 | let s = ref BatSet.empty in 57 | for i = 0 to 9999 do 58 | s := BatSet.add i !s; 59 | done; 60 | !s 61 | 62 | let test to_seq = 63 | test_input 64 | |> to_seq 65 | |> BatSeq.length 66 | 67 | let () = 68 | assert (test TooStrict.to_seq = test BatSet.to_seq); 69 | assert (test Simple.to_seq = test BatSet.to_seq); 70 | assert (test Enumeration.to_seq = test BatSet.to_seq); 71 | () 72 | 73 | let () = 74 | let repeat f n = for _i = 1 to n do ignore (f ()) done in 75 | Bench.bench_n [ 76 | "too strict", repeat (fun () -> test TooStrict.to_seq); 77 | "simple", repeat (fun () -> test Simple.to_seq); 78 | "enumeration", repeat (fun () -> test Enumeration.to_seq); 79 | "batseq", repeat (fun () -> test BatSet.to_seq); 80 | ] |> Bench.run_outputs 81 | -------------------------------------------------------------------------------- /src/batMutex.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatMutex - Additional functions for Mutexes 3 | * Copyright (C) 1996 Xavier Leroy 4 | * 1996 Damien Doligez 5 | * 2008 David Teller 6 | * 7 | * This library is free software; you can redistribute it and/or 8 | * modify it under the terms of the GNU Lesser General Public 9 | * License as published by the Free Software Foundation; either 10 | * version 2.1 of the License, or (at your option) any later version, 11 | * with the special exception on linking described in file LICENSE. 12 | * 13 | * This library is distributed in the hope that it will be useful, 14 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | * Lesser General Public License for more details. 17 | * 18 | * You should have received a copy of the GNU Lesser General Public 19 | * License along with this library; if not, write to the Free Software 20 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 21 | *) 22 | 23 | module DebugMutex = 24 | struct 25 | module M = 26 | struct 27 | type t = 28 | { mutex : Mutex.t; 29 | id : int } 30 | 31 | let unique = 32 | let counter = ref 0 33 | and mutex = Mutex.create () 34 | in 35 | fun () -> 36 | Mutex.lock mutex; 37 | let result = !counter in 38 | incr counter; 39 | Mutex.unlock mutex; 40 | result 41 | 42 | let create () = 43 | { mutex = Mutex.create () ; 44 | id = unique () } 45 | 46 | let lock t = 47 | Printf.eprintf "[Mutex] Attempting to lock mutex %d\n" t.id; 48 | Mutex.lock t.mutex; 49 | Printf.eprintf "[Mutex] Mutex %d locked\n" t.id 50 | 51 | let unlock t = 52 | Printf.eprintf "[Mutex] Attempting to unlock mutex %d\n" t.id; 53 | Mutex.unlock t.mutex; 54 | Printf.eprintf "[Mutex] Mutex %d unlocked\n" t.id 55 | 56 | let try_lock t = 57 | Printf.eprintf "[Mutex] Attempting to trylock mutex %d\n" t.id; 58 | let result = Mutex.try_lock t.mutex in 59 | Printf.eprintf "[Mutex] Mutex %d trylocked\n" t.id; 60 | result 61 | end 62 | 63 | include M 64 | module Lock = BatConcurrent.MakeLock(M) 65 | let make = Lock.make 66 | let synchronize = Lock.synchronize 67 | end 68 | 69 | module Lock = BatConcurrent.MakeLock(Mutex) 70 | let make = Lock.make 71 | let synchronize = Lock.synchronize 72 | -------------------------------------------------------------------------------- /src/batBase64.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Base64 - Base64 codec 3 | * Copyright (C) 2003 Nicolas Cannasse 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** Base64 codec. 22 | 23 | 8-bit characters are encoded into 6-bit ones using ASCII lookup tables. 24 | Default tables maps 0..63 values on characters A-Z, a-z, 0-9, '+' and '/' 25 | (in that order). 26 | 27 | @documents Base64 28 | 29 | @author Nicolas Cannasse 30 | *) 31 | 32 | (** This exception is raised when reading an invalid character 33 | from a base64 input. *) 34 | exception Invalid_char 35 | 36 | (** This exception is raised if the encoding or decoding table 37 | size is not correct. *) 38 | exception Invalid_table 39 | 40 | (** An encoding table maps integers 0..63 to the corresponding char. *) 41 | type encoding_table = char array 42 | 43 | (** A decoding table maps chars 0..255 to the corresponding 0..63 value 44 | or -1 if the char is not accepted. *) 45 | type decoding_table = int array 46 | 47 | (** Encode a string into Base64. *) 48 | val str_encode : ?tbl:encoding_table -> string -> string 49 | 50 | (** Decode a string encoded into Base64, raise [Invalid_char] if a 51 | character in the input string is not a valid one. *) 52 | val str_decode : ?tbl:decoding_table -> string -> string 53 | 54 | (** Generic base64 encoding over an output. *) 55 | val encode : ?tbl:encoding_table -> 'a BatIO.output -> 'a BatIO.output 56 | 57 | (** Generic base64 decoding over an input. *) 58 | val decode : ?tbl:decoding_table -> BatIO.input -> BatIO.input 59 | 60 | (** Create a valid decoding table from an encoding one. *) 61 | val make_decoding_table : encoding_table -> decoding_table 62 | -------------------------------------------------------------------------------- /src/batConcreteQueue_402.ml: -------------------------------------------------------------------------------- 1 | (* Explanation from OCaml 4.02 source: 2 | 3 | A queue is a reference to either nothing or some cell of a cyclic 4 | list. By convention, that cell is to be viewed as the last cell in 5 | the queue. The first cell in the queue is then found in constant 6 | time: it is the next cell in the cyclic list. The queue's length is 7 | also recorded, so as to make [length] a constant-time operation. 8 | 9 | The [tail] field should really be of type ['a cell option], but 10 | then it would be [None] when [length] is 0 and [Some] otherwise, 11 | leading to redundant memory allocation and accesses. We avoid this 12 | overhead by filling [tail] with a dummy value when [length] is 0. 13 | Of course, this requires bending the type system's arm slightly, 14 | because it does not have dependent sums. 15 | The dummy value used by the stdlib is (Obj.magic None). *) 16 | 17 | type 'a cell = { 18 | content: 'a; 19 | mutable next: 'a cell 20 | } 21 | and 'a t = { 22 | mutable length: int; 23 | mutable tail: 'a cell 24 | } 25 | 26 | external of_abstr : 'a Queue.t -> 'a t = "%identity" 27 | external to_abstr : 'a t -> 'a Queue.t = "%identity" 28 | 29 | let filter_inplace f ({tail; _} as queue) = 30 | if not (Queue.is_empty (to_abstr queue)) then 31 | let rec filter' 32 | ({ next = { content; next } as current; _ } as prev) 33 | = 34 | if f content 35 | then 36 | (* Keep cell. Recursion to next cell unless we reached the tail *) 37 | (if current != tail then filter' current) 38 | else begin 39 | (* Remove cell. *) 40 | if current != tail 41 | then begin 42 | (* Easy case. We are not removing the tail cell. *) 43 | prev.next <- next; 44 | queue.length <- queue.length - 1; 45 | (* Recursion with the same cell, 46 | * because it is now pointing beyond current. *) 47 | filter' prev 48 | end 49 | else begin 50 | (* Removing the tail cell *) 51 | if prev == current 52 | (* Tail cell is the last cell. Just clear the queue. *) 53 | then begin 54 | Queue.clear (to_abstr queue) 55 | end 56 | else begin 57 | (* Tail cell is not the last cell. 58 | * prev is the new tail. *) 59 | prev.next <- next; 60 | queue.length <- queue.length - 1; 61 | queue.tail <- prev; 62 | end 63 | end 64 | end 65 | in 66 | filter' tail 67 | -------------------------------------------------------------------------------- /src/batMultiMap.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * MultiMap - Polymorphic maps with multiple associations 3 | * Copyright (C) 1996-2003 Xavier Leroy, Nicolas Cannasse, Markus Mottl 4 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | 23 | type ('a, 'b) t = ('a, 'b BatSet.t) BatMap.t 24 | 25 | let empty = BatMap.empty 26 | 27 | let is_empty = BatMap.is_empty 28 | 29 | let find k t = try BatMap.find k t with Not_found -> BatSet.empty 30 | 31 | let add k d t = BatMap.modify_def BatSet.empty k (BatSet.add d) t 32 | 33 | let remove_all k t = BatMap.remove k t 34 | 35 | let remove k d t = 36 | try 37 | let set = BatSet.remove d (BatMap.find k t) in 38 | if BatSet.is_empty set then BatMap.remove k t 39 | else BatMap.add k set t; 40 | with Not_found -> t 41 | 42 | let mem = BatMap.mem 43 | (* let exists = mem *) 44 | let iter = BatMap.iter 45 | let map = BatMap.map 46 | let mapi = BatMap.mapi 47 | let fold = BatMap.fold 48 | let foldi = BatMap.foldi 49 | let modify = BatMap.modify 50 | let modify_def = BatMap.modify_def 51 | let modify_opt = BatMap.modify_opt 52 | 53 | let (|>) x f = f x 54 | let enum t = BatMap.enum t |> BatEnum.map (fun (k,s) -> BatSet.enum s |> BatEnum.map (fun x -> (k,x))) |> BatEnum.concat 55 | 56 | let of_enum e = BatEnum.fold (fun acc (k,d) -> add k d acc) empty e 57 | 58 | let print ?(first="{\n") ?(last="\n}") ?(sep=",\n") ?(kvsep=": ") print_k print_v out t = 59 | let print_one out (k,v) = 60 | BatPrintf.fprintf out "%a%s%a" print_k k kvsep print_v v 61 | in 62 | BatEnum.print ~first ~last ~sep print_one out (enum t) 63 | 64 | module Infix = 65 | struct 66 | let (-->) map key = find key map 67 | let (<--) map (key, value) = add key value map 68 | end 69 | -------------------------------------------------------------------------------- /benchsuite/lazylist.ml: -------------------------------------------------------------------------------- 1 | open BatLazyList 2 | 3 | (* append *) 4 | 5 | let test_append append n = 6 | for _i = 1 to n do 7 | iter ignore (BatList.fold_left append nil 8 | (BatList.init 50 (fun len -> init len (fun i -> i)))); 9 | done 10 | 11 | let append_inlined l1 l2 = 12 | let rec aux list = match next list with 13 | | Cons (x, (t : 'a t)) -> Cons (x, lazy (aux t)) 14 | | _ -> Lazy.force l2 15 | in lazy (aux l1) 16 | 17 | let append_folding l1 l2 = 18 | lazy_fold_right (fun x xs -> Cons (x, xs)) l1 l2 19 | 20 | 21 | (* concat *) 22 | 23 | let test_concat concat n = 24 | for _i = 1 to n do 25 | iter ignore (concat (init 100 (fun len -> init len (fun j -> j)))) 26 | done 27 | 28 | let concat_inlined (lol : ('a t) t) = 29 | let rec aux list = match next list with 30 | | Cons (li, t) -> Lazy.force (append li (lazy (aux t))) 31 | | Nil -> Nil 32 | in lazy (aux lol) 33 | 34 | let concat_folding lol = 35 | lazy_fold_right (fun li rest -> Lazy.force (append li rest)) lol nil 36 | 37 | 38 | (* exists *) 39 | 40 | let test_exists exists n = 41 | let len = 10_000 in 42 | for _i = 1 to n do 43 | assert (exists (fun i -> i > len / 2) (init len (fun i -> i))); 44 | done 45 | 46 | let exists_inlined f l = 47 | let rec aux rest = match next rest with 48 | | Cons (x, _) when f x -> true 49 | | Cons (_, t) -> aux t 50 | | Nil -> false 51 | in aux l 52 | 53 | let exists_folding p l = 54 | let test x rest = p x || Lazy.force rest in 55 | Lazy.force (lazy_fold_right test l (Lazy.from_val false)) 56 | 57 | 58 | 59 | let () = 60 | let append_benchs = Bench.bench_n [ 61 | "append inlined", test_append append_inlined; 62 | "append folding", test_append append_folding; 63 | ] in 64 | let concat_benchs = Bench.bench_n [ 65 | "concat inlined", test_concat concat_inlined; 66 | "concat folding", test_concat concat_folding; 67 | ] in 68 | let exists_benchs = Bench.bench_n [ 69 | "exists inlined", test_exists exists_inlined; 70 | "exists folding", test_exists exists_folding; 71 | ] in 72 | List.iter Bench.summarize [ append_benchs; concat_benchs; exists_benchs ] 73 | 74 | (* some approximate results: 75 | append inlined (2.82 ms) is 10.2% faster than 76 | append folding (3.14 ms) 77 | concat folding (1.38 ms) is probably (alpha=47.71%) same speed as 78 | concat inlined (1.39 ms) 79 | exists inlined (546.18 us) is 53.5% faster than 80 | exists folding (1.18 ms) 81 | *) 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /src/batStack.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatQueue - Extended operations on queues 3 | * Copyright (C) 1996 Xavier Leroy 4 | * 2008 David Teller, LIFO, Universite d'Orleans 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | 23 | include Stack 24 | 25 | type 'a enumerable = 'a Stack.t 26 | 27 | let of_enum e = 28 | let s = create () in 29 | BatEnum.iter (fun x -> push x s) e; 30 | s 31 | 32 | (*$T of_enum 33 | let s = create () in push 3 s; push 5 s; [3;5] |> List.enum |> of_enum = s 34 | let s = create () in of_enum (BatEnum.empty ()) = s 35 | *) 36 | 37 | (* Consumes input stack *) 38 | let enum_destruct s = 39 | let get () = try pop s with Stack.Empty -> raise BatEnum.No_more_elements in 40 | BatEnum.from get 41 | 42 | (*$T enum_destruct 43 | let s = of_enum (List.enum [2;4;6;8]) in \ 44 | enum_destruct s |> List.of_enum = [8;6;4;2] && is_empty s 45 | *) 46 | 47 | (* consumes a copy *) 48 | let enum s = enum_destruct (copy s) 49 | 50 | let print ?(first="") ?(last="") ?(sep="") print_a out t = 51 | BatEnum.print ~first ~last ~sep print_a out (enum t) 52 | 53 | (*$T print 54 | IO.to_string (print Int.print) (of_enum (List.enum [2;4;6;8])) = "8642" 55 | *) 56 | 57 | let compare cmp a b = BatEnum.compare cmp (enum a) (enum b) 58 | let equal eq a b = BatEnum.equal eq (enum a) (enum b) 59 | 60 | (*$T equal 61 | not (equal Int.equal (create()) (of_enum (List.enum [2]))) 62 | equal Int.equal (create()) (create()) 63 | equal Int.equal (of_enum (List.enum [2])) (of_enum (List.enum [2])) 64 | *) 65 | 66 | (*$T compare 67 | 0 <> (compare Int.compare (create()) (of_enum (List.enum [2]))) 68 | *) 69 | 70 | module Exceptionless = struct 71 | let top s = try Some (top s) with Empty -> None 72 | let pop s = try Some (pop s) with Empty -> None 73 | end 74 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name batteries_unthreaded) 3 | (public_name batteries.unthreaded) 4 | (synopsis "Batteries Included (for use in unthreaded programs)") 5 | (modules (:standard \ batteries_compattest batConcreteQueue_402 6 | batConcreteQueue_403 batteriesThread batRMutex 7 | batMutex)) 8 | (preprocess 9 | (action (run %{project_root}/build/prefilter.exe %{input-file}))) 10 | (flags (:standard -w -3-32-50-52)) 11 | (libraries num str camlp-streams unix bigarray) 12 | (inline_tests 13 | (backend qtest_batteries) 14 | (deps %{project_root}/qtest/qtest_preamble.ml 15 | ;; fix 'dune clean && dune build @src/runtest' (opam CI tests) 16 | batteriesConfig.ml batConcreteQueue.ml)) 17 | (wrapped false) 18 | ) 19 | 20 | (library 21 | (name batteries) 22 | (public_name batteries) 23 | (synopsis 24 | "Batteries Included is a community-maintained standard library extension") 25 | (modules batteriesThread batRMutex batMutex) 26 | (preprocess 27 | (action (run %{project_root}/build/prefilter.exe %{input-file}))) 28 | (flags (:standard -w -3-32-50-52)) 29 | (libraries batteries.unthreaded threads) 30 | (inline_tests 31 | (backend qtest_batteries) 32 | (deps %{project_root}/qtest/qtest_preamble.ml) 33 | ) 34 | (wrapped false) 35 | ) 36 | 37 | (rule 38 | (action (copy# batConcreteQueue_402.ml batConcreteQueue.ml)) 39 | (enabled_if (< %{ocaml_version} 4.03)) 40 | ) 41 | 42 | (rule 43 | (action (copy# batConcreteQueue_403.ml batConcreteQueue.ml)) 44 | (enabled_if (>= %{ocaml_version} 4.03)) 45 | ) 46 | 47 | (library 48 | (name qtest_batteries) 49 | (modules) 50 | (inline_tests.backend 51 | (generate_runner (pipe-stdout (run qtest extract --preamble-file 52 | %{dep:../qtest/qtest_preamble.ml} --quiet %{impl-files} %{intf-files}) 53 | ;; inline_tests gets unpreprocessed files, apply prefilter here as well 54 | (run ../build/prefilter.exe))) 55 | (runner_libraries qcheck ounit2) 56 | )) 57 | 58 | (rule 59 | (target batteriesConfig.ml) 60 | (deps %{project_root}/build/mkconf.exe %{project_root}/VERSION 61 | batteriesConfig.mlp) 62 | (action 63 | (run %{project_root}/build/mkconf.exe %{project_root}/VERSION 64 | batteriesConfig.mlp %{target}))) 65 | 66 | (test 67 | (name batteries_compattest) 68 | (modules batteries_compattest) 69 | (preprocess 70 | (action (run %{project_root}/build/prefilter.exe %{input-file}))) 71 | (libraries batteries)) 72 | 73 | ; build documentation 74 | ; dune build @doc 75 | ; xdg-open _build/default/_doc/_html/index.html 76 | (documentation 77 | (mld_files index)) 78 | -------------------------------------------------------------------------------- /src/batGlobal.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Global - Mutable global variable 3 | * Copyright (C) 2003 Nicolas Cannasse 4 | * Copyright (C) 2008 David Teller 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | (** Mutable global variable. 23 | 24 | Often in OCaml you want to have a global variable, which is mutable 25 | and uninitialized when declared. You can use a ['a option ref] but 26 | this is not very convenient. The Global module provides functions 27 | to easily create and manipulate such variables. 28 | 29 | @author Nicolas Cannasse 30 | @author David Teller (boilerplate code) 31 | *) 32 | 33 | type 'a t 34 | (** Abstract type of a global *) 35 | 36 | exception Global_not_initialized of string 37 | (** Raised when a global variable is accessed without first having been 38 | assigned a value. The parameter contains the name of the global. *) 39 | 40 | val empty : string -> 'a t 41 | (** Returns an new named empty global. The name of the global can be 42 | any string. It identifies the global and makes debugging 43 | easier. Using the same string twice will not return the same 44 | global twice, but will create two globals with the same name. 45 | *) 46 | 47 | val name : 'a t -> string 48 | (** Retrieve the name of a global. *) 49 | 50 | val set : 'a t -> 'a -> unit 51 | (** Set the global value contents. *) 52 | 53 | val get_exn : 'a t -> 'a 54 | (** Get the global value contents - raise Global_not_initialized if not 55 | defined. *) 56 | 57 | val get : 'a t -> 'a option 58 | (** Return [None] if the global is undefined, else [Some v] where [v] is 59 | the current global value contents. *) 60 | 61 | val undef : 'a t -> unit 62 | (** Reset the global value contents to undefined. *) 63 | 64 | val isdef : 'a t -> bool 65 | (** Return [true] if the global value has been set. *) 66 | -------------------------------------------------------------------------------- /src/batUChar.ml: -------------------------------------------------------------------------------- 1 | (** Unicode (ISO-UCS) characters. 2 | 3 | This module implements Unicode characters. 4 | *) 5 | 6 | (* Copyright (C) 2002, 2003, 2004 Yamagata Yoriyuki. *) 7 | 8 | (* This library is free software; you can redistribute it and/or *) 9 | (* modify it under the terms of the GNU Lesser General Public License *) 10 | (* as published by the Free Software Foundation; either version 2 of *) 11 | (* the License, or (at your option) any later version. *) 12 | 13 | (* As a special exception to the GNU Library General Public License, you *) 14 | (* may link, statically or dynamically, a "work that uses this library" *) 15 | (* with a publicly distributed version of this library to produce an *) 16 | (* executable file containing portions of this library, and distribute *) 17 | (* that executable file under terms of your choice, without any of the *) 18 | (* additional requirements listed in clause 6 of the GNU Library General *) 19 | (* Public License. By "a publicly distributed version of this library", *) 20 | (* we mean either the unmodified Library as distributed by the authors, *) 21 | (* or a modified version of this library that is distributed under the *) 22 | (* conditions defined in clause 3 of the GNU Library General Public *) 23 | (* License. This exception does not however invalidate any other reasons *) 24 | (* why the executable file might be covered by the GNU Library General *) 25 | (* Public License . *) 26 | 27 | (* This library is distributed in the hope that it will be useful, *) 28 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 29 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) 30 | (* Lesser General Public License for more details. *) 31 | 32 | (* You should have received a copy of the GNU Lesser General Public *) 33 | (* License along with this library; if not, write to the Free Software *) 34 | (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *) 35 | (* USA *) 36 | 37 | (* You can contact the authour by sending email to *) 38 | (* yoriyuki.y@gmail.com *) 39 | 40 | type t = int 41 | 42 | exception Out_of_range 43 | 44 | external code : t -> int = "%identity" 45 | 46 | let char_of c = 47 | if c >= 0 && c < 0x100 then Char.chr c else raise Out_of_range 48 | 49 | let of_char = Char.code 50 | 51 | (* valid range: U+0000..U+D7FF and U+E000..U+10FFFF *) 52 | let chr n = 53 | if (n >= 0 && n <= 0xd7ff) || (n >= 0xe000 && n <= 0x10ffff) 54 | then n 55 | else raise Out_of_range 56 | 57 | let unsafe_chr n = n 58 | 59 | let eq (u1 : t) (u2 : t) = u1 = u2 60 | 61 | let compare u1 u2 = u1 - u2 62 | 63 | type uchar = t 64 | 65 | let int_of u = code u 66 | let of_int n = chr n 67 | 68 | let is_ascii u = u < 128 69 | -------------------------------------------------------------------------------- /check_raise: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # Simple sanity checking of documentation of exceptions. 3 | # Usage: go to src/ and run ../check_raise 4 | 5 | header() { 6 | info=$1 7 | shift 8 | result=$(mktemp) 9 | $* >$result 10 | cw=$(wc -w $result | cut -f1 -d\ ) 11 | if [ "$cw" -ne "0" ] 12 | then 13 | echo $info 14 | cat $result 15 | echo 16 | fi 17 | } 18 | 19 | setminus() { 20 | diff --new-line-format= --unchanged-line-format= $1 $2 21 | } 22 | 23 | # Capitalized Raise should be rare 24 | header "Interesting places:" \ 25 | grep -n Raise *.ml *.mli | grep -v " *Raised" 26 | 27 | #header "Needs source style:" \ 28 | # grep -n "Invalid_argument[[:space:]]\"" *.mli 29 | 30 | # Modules known to have documentation of exceptions OK 31 | already_ok=$(mktemp) 32 | echo " 33 | batteriesHelp 34 | batStack 35 | batSplay 36 | batReturn 37 | batRef 38 | batRandom 39 | batQueue 40 | batDeque 41 | batConcurrent 42 | batCharParser 43 | " | sort >$already_ok 44 | 45 | use_raise=$(mktemp) 46 | doc_raise=$(mktemp) 47 | poor_doc_raise=$(mktemp) 48 | to_be_verified=$(mktemp) 49 | 50 | # Crude check for presence of exceptions in implementations and interfaces 51 | grep -n "\(raise\|invalid_arg\|failwith\)" *.ml | cut -f1 -d. | uniq | sort >$use_raise 52 | grep -n @raise *.mli | cut -f1 -d. | uniq | sort >$doc_raise 53 | grep -ni raise *.mli | cut -f1 -d. | uniq | sort >$poor_doc_raise 54 | 55 | setminus $use_raise $already_ok >$to_be_verified 56 | 57 | suspicious=$(mktemp) 58 | setminus $to_be_verified $doc_raise >$suspicious 59 | 60 | need_doc=$(mktemp) 61 | setminus $suspicious $poor_doc_raise >$need_doc 62 | 63 | header "Documentation of the following modules mentions exceptions and awaits formal @raise clauses:" \ 64 | setminus $suspicious $need_doc 65 | 66 | header "The following modules need raised exceptions to be documented (quite likely):" \ 67 | cat $need_doc 68 | 69 | # A policy: don't expose string arguments of standard exceptions 70 | header "String arguments nobody should rely upon:" \ 71 | grep -n "Invalid_argument[[:space:]]\"" *.mli 72 | 73 | header "String arguments nobody should rely upon:" \ 74 | grep -n "Failure[[:space:]]\"" *.mli 75 | 76 | # Look for mistakes 77 | 78 | header "@raises instead of @raise:" \ 79 | grep -n @raises *.ml *.mli 80 | 81 | header "Square brackets that harm ocamldoc:" \ 82 | grep -n "@raise[[:space:]]\[" *.ml *.mli 83 | 84 | header Typos: \ 85 | grep -n "Invalid_arg[[:space:]]" `find . -type f -not -name batDynArray\*` 86 | 87 | header Typos: \ 88 | grep -n Invald_argument *.ml *.mli 89 | 90 | header "consisting in => consisting of" 91 | grep -n "consisting in" *.ml *.mli 92 | 93 | header "@since NEXT_RELEASE should be filled before release" 94 | grep "@since [^0123456789]" *.ml *.mli 95 | -------------------------------------------------------------------------------- /testsuite/test_string.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open BatString 3 | 4 | let string = "Jon \"Maddog\" Orwant" 5 | 6 | open BatEnum 7 | (* 8 | let test_take_and_skip () = 9 | let foo s : string list = 10 | let e = enum s in 11 | [? List : of_enum (f e) | 12 | f <- List : [take 5; skip 3 %> take 5; take 5 ; identity] ?] 13 | in 14 | assert_equal ~printer:(Printf.sprintf2 "%a" (List.print String.print_quoted)) 15 | ["Jon \""; "dog\" "; "Orwan"; "t"] 16 | (foo string) 17 | *) 18 | 19 | let test_starts_with () = 20 | let check expected prefix = 21 | let s = match expected with true -> "" | false -> "not " in 22 | if starts_with string prefix <> expected then 23 | assert_failure (Printf.sprintf "String %S should %sstart with %S" 24 | string s prefix) 25 | in 26 | check true "Jon"; 27 | check false "Jon \"Maddog\" Orwants"; 28 | check false "Orwants" 29 | 30 | let test_ends_with () = 31 | let check expected suffix = 32 | let s = match expected with true -> "" | false -> "not " in 33 | if ends_with string suffix <> expected then 34 | assert_failure (Printf.sprintf "String %S should %send with %S" 35 | string s suffix) 36 | in 37 | check true "want"; 38 | check false "I'm Jon \"Maddog\" Orwant"; 39 | check false "Jon" 40 | 41 | let test_nsplit () = 42 | let printer = BatPrintf.sprintf2 "%a" (BatList.print BatString.print) in 43 | let check exp s sep = assert_equal ~printer exp (nsplit s sep) in 44 | check ["a"; "b"; "c"] "a/b/c" "/"; 45 | check [""; "a"; "b"; "c"; ""; ""] "/a/b/c//" "/"; 46 | check [""; "a"; "b"; "c"; ""; ""] "FOOaFOObFOOcFOOFOO" "FOO" 47 | 48 | let assert_no_raises : ?msg:string -> (unit -> 'a) -> 'a = 49 | fun ?(msg="Function raised an exception when none was expected.") f -> 50 | try 51 | f () 52 | with exn -> 53 | assert_failure (msg ^ " " ^ Printexc.to_string exn) 54 | 55 | let test_exists () = 56 | let check haystack needle expected = 57 | let msg = 58 | Printf.sprintf "exists \"%s\" \"%s\" = %b" 59 | (String.escaped haystack) (String.escaped needle) 60 | expected 61 | in 62 | assert_equal 63 | ~msg 64 | (assert_no_raises ~msg:(msg ^ " raised exception ") 65 | (fun () -> BatString.exists haystack needle)) 66 | expected 67 | in 68 | check "" "" true; 69 | check "a" "" true; 70 | check "" "a" false; 71 | check "ab" "a" true; 72 | check "ab" "b" true; 73 | check "ab" "c" false 74 | 75 | let tests = "String" >::: [ 76 | (* "Taking and skipping" >:: test_take_and_skip; *) 77 | "Start with" >:: test_starts_with; 78 | "Ends with" >:: test_ends_with; 79 | "Splitting with nsplit" >:: test_nsplit; 80 | "Exists" >:: test_exists; 81 | ] 82 | -------------------------------------------------------------------------------- /src/batInnerPervasives.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Copyright (C) 2012 Batteries Included Development Team 3 | * 4 | * This library is free software; you can redistribute it and/or 5 | * modify it under the terms of the GNU Lesser General Public 6 | * License as published by the Free Software Foundation; either 7 | * version 2.1 of the License, or (at your option) any later version, 8 | * with the special exception on linking described in file LICENSE. 9 | * 10 | * This library is distributed in the hope that it will be useful, 11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 13 | * Lesser General Public License for more details. 14 | * 15 | * You should have received a copy of the GNU Lesser General Public 16 | * License along with this library; if not, write to the Free Software 17 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 18 | *) 19 | 20 | (* Inner functions for Pervasives, that can be accessed from other 21 | modules without pulling in all of batteries as deps. *) 22 | 23 | let finally handler f x = 24 | let r = ( 25 | try 26 | f x 27 | with 28 | e -> handler(); raise e 29 | ) in 30 | handler(); 31 | r 32 | 33 | let with_dispose ~dispose f x = 34 | finally (fun () -> dispose x) f x 35 | 36 | (* unique int generation *) 37 | let unique_value = ref 0 38 | let lock = ref BatConcurrent.nolock 39 | let unique () = 40 | BatConcurrent.sync !lock BatRef.post_incr unique_value 41 | 42 | (*$Q unique 43 | Q.unit (fun () -> unique () <> unique ()) 44 | *) 45 | 46 | type ('a, 'b) result = 47 | ##V>=4.8## ('a, 'b) Stdlib.result = 48 | | Ok of 'a 49 | | Error of 'b 50 | 51 | (* Ideas taken from Nicholas Pouillard's my_std.ml in ocamlbuild/ *) 52 | let ignore_ok = function 53 | Ok _ -> () 54 | | Error ex -> raise ex 55 | 56 | let ok = function 57 | Ok v -> v 58 | | Error ex -> raise ex 59 | 60 | let wrap f x = try Ok (f x) with ex -> Error ex 61 | 62 | let forever f x = ignore (while true do ignore (f x) done) 63 | 64 | let ignore_exceptions f x = try ignore (f x) with _ -> () 65 | 66 | 67 | (** {1 Operators}*) 68 | 69 | ##V<4## let ( |> ) x f = f x 70 | ##V>=4## external (|>) : 'a -> ('a -> 'b) -> 'b = "%revapply" 71 | 72 | ##V<4## let ( @@ ) f x = f x 73 | ##V>=4## external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" 74 | 75 | let ( %> ) f g x = g (f x) 76 | 77 | let ( % ) f g x = f (g x) 78 | 79 | let flip f x y = f y x 80 | 81 | let curry f x y = f (x,y) 82 | 83 | let uncurry f (x,y) = f x y 84 | 85 | let const x _ = x 86 | 87 | let neg p x = not (p x) 88 | 89 | let neg2 p x y = not (p x y) 90 | 91 | external identity : 'a -> 'a = "%identity" 92 | 93 | let tap f x = f x; x 94 | 95 | let ( |? ) = BatOption.Infix.( |? ) 96 | -------------------------------------------------------------------------------- /testsuite/test_random.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | let assert_equal_arrays = 4 | assert_equal ~printer:(BatIO.to_string (BatArray.print BatInt.print)) 5 | 6 | let take_array n e = BatArray.of_enum (BatEnum.take n e) 7 | 8 | let test_enum_helper reset create modify = 9 | let make n = take_array n (create ()) in 10 | 11 | (* Enumerations constructed for the same state should be equal. *) 12 | let () = reset () in 13 | let a = make 10 in 14 | let () = reset () in 15 | let b = make 10 in 16 | let () = assert_equal_arrays a b in 17 | 18 | (* The states should be shared: if the state is modified then the second 19 | stream should be different. *) 20 | let () = reset () in 21 | let a = make 1000 in 22 | let () = reset () in 23 | let () = modify () in 24 | let b = make 1000 in 25 | let () = assert_bool "Different states but equal arrays" (a <> b) in 26 | 27 | (* Cloning should work even if the RNG state is changing. *) 28 | let e = create () in 29 | let e_clone = BatEnum.clone e in 30 | let () = modify () in 31 | assert_equal_arrays 32 | (take_array 10 e) 33 | (take_array 10 e_clone) 34 | 35 | (* Wrapper that assures that [cmd] does not modify the default state. *) 36 | let with_saved_state cmd = 37 | let state = BatRandom.get_state () in 38 | let () = cmd () in 39 | BatRandom.set_state state 40 | 41 | let test_enum_default () = 42 | let reset () = BatRandom.init 0 in 43 | let create () = BatRandom.enum_int 100 in 44 | let modify () = let _ = BatRandom.int 100 in () in 45 | with_saved_state 46 | (fun () -> test_enum_helper reset create modify) 47 | 48 | let test_enum_state () = 49 | let make_seed () = BatRandom.State.make [| 0 |] in 50 | let state = ref (make_seed ()) in 51 | let reset () = state := make_seed () in 52 | let create () = BatRandom.State.enum_int !state 100 in 53 | let modify () = let _ = BatRandom.State.int !state 100 in () in 54 | test_enum_helper reset create modify 55 | 56 | module PSE = BatRandom.Incubator.Private_state_enums 57 | 58 | let test_enum_default_priv () = 59 | let reset () = BatRandom.init 0 in 60 | let create () = PSE.enum_int 100 in 61 | let modify () = let _ = BatRandom.int 100 in () in 62 | with_saved_state (fun () -> test_enum_helper reset create modify) 63 | 64 | let test_enum_state_priv () = 65 | let make_seed () = BatRandom.State.make [| 0 |] in 66 | let state = ref (make_seed ()) in 67 | let reset () = state := make_seed () in 68 | let create () = PSE.State.enum_int !state 100 in 69 | let modify () = let _ = PSE.State.int !state 100 in () in 70 | test_enum_helper reset create modify 71 | 72 | 73 | let tests = "BatRandom" >::: [ 74 | "enum_default" >:: test_enum_default; 75 | "enum_state" >:: test_enum_state; 76 | "enum_default_priv" >:: test_enum_default_priv; 77 | "enum_state_priv" >:: test_enum_state_priv; 78 | ] 79 | -------------------------------------------------------------------------------- /testsuite/test_pervasives.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | open Batteries 3 | 4 | let test_using () = 5 | let obj = (ref 0), (ref 0) in 6 | let dispose (_,closed) = closed := 5 in 7 | let f (run,_) = run := 7; 42 in 8 | let r = with_dispose ~dispose f obj in 9 | let printer = string_of_int in 10 | let run, closed = obj in 11 | assert_equal ~printer 42 r; 12 | assert_equal ~printer 7 (!run); 13 | assert_equal ~printer 5 (!closed) 14 | 15 | type test1 = 16 | | A of int 17 | | B of float * float 18 | | C of string * test1 19 | 20 | type test2 = { 21 | a : int; 22 | b : float * float; 23 | c : string * test2 option; 24 | } 25 | 26 | type test3 = { 27 | f1 : float; 28 | f2 : float; 29 | f3 : float; 30 | } 31 | 32 | let test_dump () = 33 | let test str value = 34 | assert_equal ~msg:str ~printer:(fun x -> x) str (BatPervasives.dump value) in 35 | 36 | (* integers *) 37 | test "0" None; 38 | test "0" false; 39 | test "1" true; 40 | test "17" 17; 41 | 42 | (* lists *) 43 | (* despite the specialized list-spotting routine, [] is printed as 44 | 0 as they have the same representation *) 45 | test "0" []; 46 | test "[1; 2]" [1; 2]; 47 | 48 | (* algebraic datatypes *) 49 | test "(1)" (A 1); 50 | test "Tag1 (2., 3.)" (B (2.,3.)); 51 | test "Tag2 (\"foo\", (1))" (C ("foo", A 1)); 52 | 53 | test "(1, (2., 3.), [\"foo\"])" {a = 1; b = (2., 3.); c = "foo", None}; 54 | 55 | (* tuples *) 56 | test "(1, 2)" (1,2); 57 | test "[0]" (0,0); 58 | 59 | (* lazy *) 60 | (* lazy immediate values are not lazyfied! 61 | test "0" (lazy 0); *) 62 | test "" (lazy (ignore ())); 63 | 64 | (* closures *) 65 | test "" (fun x -> x); 66 | 67 | (* objects *) 68 | let obj = object 69 | val x = 2 70 | val z = 3. 71 | method foo = "bar" end in 72 | test (Printf.sprintf "Object #%d (2, 3.)" (Oo.id obj)) obj; 73 | 74 | (* infix, forward? *) 75 | 76 | (* string *) 77 | let str = "foo \"bar\"\n" in 78 | test (Printf.sprintf "%S" str) str; 79 | 80 | (* double *) 81 | let test_float x = test (string_of_float x) x in 82 | List.iter test_float 83 | [0.; 1.; -2.; max_float; min_float; epsilon_float; nan]; 84 | for _i = 0 to 1000 do 85 | test_float (Random.float max_float); 86 | test_float (Random.float min_float); 87 | done; 88 | 89 | (* abstract? *) 90 | 91 | (* custom? *) 92 | 93 | (* final? *) 94 | 95 | 96 | (* double array or struct *) 97 | let test_arr arr v = 98 | test (BatIO.to_string (BatArray.print BatFloat.print) arr) v in 99 | test "()" ([| |] : float array); 100 | test_arr [| 0.; 1.; 2. |] [| 0.; 1.; 2. |]; 101 | test_arr [| 0.; 1.; 2. |] { f1 = 0.; f2 = 1.; f3 = 2. }; 102 | 103 | () 104 | 105 | let tests = "Std" >::: [ 106 | "using" >:: test_using; 107 | "dump" >:: test_dump; 108 | ];; 109 | -------------------------------------------------------------------------------- /src/batReturn.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Return -- fast return in OCaml 3 | * Copyright (C) 2008 David Teller 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** 22 | Local exceptions/labels/goto/return. 23 | 24 | This module defines a mechanism akin to SML's exception generators 25 | or to a generalization of C's [return], i.e. the ability to define 26 | local {i labels}, which may be used for immediately terminating an 27 | expression and returning a value. By opposition to usual OCaml 28 | exceptions, this mechanism 29 | - allows polymorphic return values 30 | - makes accidental exception catching slightly harder (while a local 31 | exception can escape its scope, it cannot be caught again by accident 32 | from this module). 33 | 34 | Example: 35 | {[ 36 | let find_in_array a e = 37 | label (fun label -> 38 | for i = 0 to Array.length a - 1 do 39 | if Array.get a i = e then return label (Some i) 40 | done; 41 | None) 42 | ]} 43 | 44 | @author David Teller 45 | 46 | @documents Return 47 | *) 48 | 49 | type 'a t 50 | (** A label which may be used to return values of type ['a]*) 51 | 52 | val label : ('a t -> 'a) -> 'a 53 | (** [label f] creates a new label [x] and invokes 54 | [f x]. If, during the execution of [f], [return x v] 55 | is invoked, the execution of [f x] stops 56 | immediately and [label f] returns [v]. 57 | Otherwise, if [f x] terminates normally and 58 | returns [y], [label f] returns [y]. 59 | 60 | Calling [return x v] from outside scope [f] 61 | is a run-time error and causes termination 62 | of the program.*) 63 | 64 | val with_label : ('a t -> 'a) -> 'a 65 | (**as [label]*) 66 | 67 | val return : 'a t -> 'a -> _ 68 | (** Return to a label. [return l v] returns 69 | to the point where label [l] was obtained 70 | and produces value [l]. 71 | 72 | Calling [return l v] from outside the scope 73 | of [l] (i.e. the call to function [label] 74 | which produced [l]) is a run-time error 75 | and causes termination of the program.*) 76 | 77 | -------------------------------------------------------------------------------- /testsuite/test_toplevel.ml: -------------------------------------------------------------------------------- 1 | open OUnit 2 | 3 | (*Source code which needs to be executed*) 4 | 5 | let make_temporary_file content = 6 | File.with_temporary_out ~suffix:".ml" 7 | begin 8 | fun out name -> 9 | String.print out content; 10 | name 11 | end 12 | 13 | let expected = "read-only string";; 14 | 15 | open Compilers 16 | open IO 17 | 18 | let test_from_source_file () = 19 | let source = "Print.printf p\"%sc\" ro\"read-only string\";;" in 20 | let generated_file = make_temporary_file source in 21 | let temp_name = Filename.temp_file "ocaml" "test" in 22 | ignore (Sys.command (string_of_command (ocaml [generated_file]) ^ " > " ^ temp_name)); 23 | let obtained = File.with_file_in temp_name read_all in 24 | assert_equal ~printer:(Printf.sprintf "%S") expected obtained 25 | 26 | let test_from_simulated_cmdline () = 27 | let temp_name = Filename.temp_file "ocaml" "test" in 28 | let source = Print.sprintf 29 | p"File.with_file_out %S (fun out -> Print.fprintf out p\"%%sc\" ro\"read-only string\");;\n" 30 | temp_name in 31 | let generated_file = make_temporary_file source in 32 | let command = string_of_command (ocaml []) ^ " < " ^ generated_file ^ " > /dev/null " in 33 | (* Printf.eprintf "Running %S\nWriting to file %S\n%!" command temp_name;*) 34 | ignore (Sys.command command); 35 | flush_all (); 36 | let obtained = File.with_file_in temp_name read_all in 37 | assert_equal ~printer:(Printf.sprintf "%S") expected obtained 38 | 39 | (* 40 | let test_1 = 41 | ("OCaml: Testing from source file", fun () -> 42 | try 43 | let generated_file = 44 | File.with_temporary_out ~suffix:".ml" 45 | begin 46 | fun out name -> 47 | String.print out source; 48 | name 49 | end 50 | in 51 | let temp_name = Filename.temp_file "ocaml" "test" in 52 | ignore (Sys.command (string_of_command (ocaml [generated_file]) ^ "> temp_name")); 53 | let obtained = File.with_file_in temp_name read_all 54 | in 55 | if obtained = expected then Testing.Pass 56 | else Testing.Fail (Printf.sprintf "Expected: %S\n\tObtained: %S\n" expected obtained) 57 | with e -> Testing.Err (Printexc.to_string e)) 58 | 59 | let test_2 = 60 | ("OCaml: Testing from simulated command-line", fun () -> 61 | try 62 | let command = string_of_command (ocaml []) in 63 | let (pin, pout)=Unix.open_process ~cleanup:true command in 64 | String.print pout source; 65 | close_out pout; 66 | let obtained = read_all pin in 67 | if obtained = expected then Testing.Pass 68 | else Testing.Fail (Printf.sprintf "Expected: %S\n\tObtained: %S\n" expected obtained) 69 | with e -> Testing.Err (Printexc.to_string e)) 70 | 71 | *) 72 | 73 | let tests = "Toplevel" >::: [ 74 | "From source file" >:: test_from_source_file; 75 | "From simulated command-line" >:: test_from_simulated_cmdline; 76 | ] 77 | -------------------------------------------------------------------------------- /benchsuite/bitset.ml: -------------------------------------------------------------------------------- 1 | let width = 100000 2 | let op_count = 1000 3 | let set_poss = Array.init op_count (fun _ -> Random.int width) 4 | let clear_poss = Array.init op_count (fun _ -> Random.int width) 5 | let get_poss = Array.init op_count (fun _ -> Random.int width) 6 | 7 | let fill_arr s = 8 | for i = 0 to op_count-1 do 9 | s.(Array.unsafe_get clear_poss i) <- false; 10 | s.(Array.unsafe_get set_poss i) <- true; 11 | done 12 | 13 | let farr n = 14 | let s = Array.make width false in 15 | for _a = 1 to n do 16 | fill_arr s; 17 | for _b = 1 to 100 do 18 | for i = 0 to op_count-1 do 19 | let _bool : bool = 20 | s.(Array.unsafe_get get_poss i) 21 | in 22 | () 23 | done 24 | done 25 | done 26 | 27 | let count_arr n = 28 | let s = Array.make width false in 29 | for _a = 1 to n do 30 | let count = ref 0 in 31 | fill_arr s; 32 | for i = 0 to op_count-1 do 33 | if s.(i) then incr count; 34 | done 35 | done 36 | 37 | let next_bit_set_arr n = 38 | count_arr n (* Code almost look like count_arr *) 39 | 40 | open Batteries 41 | 42 | let fill_bitset s = 43 | for i = 0 to op_count-1 do 44 | BitSet.unset s (Array.unsafe_get clear_poss i); 45 | BitSet.set s (Array.unsafe_get set_poss i); 46 | done 47 | 48 | let fbs n = 49 | let s = BitSet.create width in 50 | for _a = 1 to n do 51 | fill_bitset s; 52 | for _b = 1 to 100 do 53 | for i = 0 to op_count-1 do 54 | let _bool : bool = 55 | BitSet.mem s (Array.unsafe_get get_poss i) 56 | in 57 | () 58 | done 59 | done 60 | done 61 | 62 | let count_bitset n = 63 | let s = BitSet.create width in 64 | for _a = 1 to n do 65 | fill_bitset s; 66 | let _count: int = BitSet.count s in 67 | () 68 | done 69 | 70 | let next_bit_set_bitset n = 71 | let s = BitSet.create width in 72 | for _a = 1 to n do 73 | let res = ref (Some 0) in 74 | fill_bitset s; 75 | while !res <> None do 76 | match !res with 77 | | Some idx -> 78 | res := BitSet.next_set_bit s (idx + 1) 79 | | None -> 80 | () 81 | done 82 | done 83 | 84 | let next_bit_set_enum n = 85 | let s = BitSet.create width in 86 | for _a = 1 to n do 87 | let () = fill_bitset s in 88 | let enum = BitSet.enum s in 89 | BatEnum.iter ignore enum 90 | done 91 | 92 | let () = 93 | Bench.config.Bench.gc_between_tests <- true; 94 | Bench.bench_n ["bitset.general", fbs; "array.general", farr] 95 | |> Bench.summarize ~alpha:0.05; 96 | Bench.bench_n ["bitset.count", count_bitset; "array.count", count_arr] 97 | |> Bench.summarize ~alpha:0.05; 98 | Bench.bench_n ["bitset.next", next_bit_set_bitset; 99 | "array.next", next_bit_set_arr; 100 | "bitset(enum).next", next_bit_set_enum] 101 | |> Bench.summarize ~alpha:0.05; 102 | -------------------------------------------------------------------------------- /examples/benchmark/t_read.log: -------------------------------------------------------------------------------- 1 | Latencies for 30 iterations of "mmap_fn", "pread", "batio", "cdk_orig", "cdk2k", "cdk4k", "vbu1k", "vbu2k", "vbu4k", "vbp1k", "vbp2k", "vbp4k", "bitstring", "str_only": 2 | mmap_fn: 18.83 WALL (18.23 usr + 0.60 sys = 18.83 CPU) @ 1.59/s (n=30) 3 | pread: 23.47 WALL (18.78 usr + 4.69 sys = 23.47 CPU) @ 1.28/s (n=30) 4 | batio: 28.79 WALL (27.05 usr + 1.74 sys = 28.79 CPU) @ 1.04/s (n=30) 5 | cdk_orig: 27.61 WALL (25.00 usr + 2.61 sys = 27.61 CPU) @ 1.09/s (n=30) 6 | cdk2k: 29.25 WALL (26.34 usr + 2.90 sys = 29.24 CPU) @ 1.03/s (n=30) 7 | cdk4k: 27.29 WALL (25.38 usr + 1.90 sys = 27.28 CPU) @ 1.10/s (n=30) 8 | vbu1k: 28.93 WALL (26.49 usr + 2.42 sys = 28.91 CPU) @ 1.04/s (n=30) 9 | vbu2k: 27.78 WALL (25.79 usr + 1.98 sys = 27.77 CPU) @ 1.08/s (n=30) 10 | vbu4k: 28.18 WALL (26.55 usr + 1.63 sys = 28.18 CPU) @ 1.06/s (n=30) 11 | vbp1k: 30.82 WALL (27.97 usr + 2.84 sys = 30.81 CPU) @ 0.97/s (n=30) 12 | vbp2k: 29.05 WALL (26.71 usr + 2.33 sys = 29.04 CPU) @ 1.03/s (n=30) 13 | vbp4k: 28.31 WALL (26.63 usr + 1.68 sys = 28.31 CPU) @ 1.06/s (n=30) 14 | bitstring: 28.33 WALL (26.57 usr + 1.76 sys = 28.33 CPU) @ 1.06/s (n=30) 15 | str_only: 24.43 WALL (21.22 usr + 3.20 sys = 24.42 CPU) @ 1.23/s (n=30) 16 | Rate vbp1k cdk2k vbp2k vbu1k batio bitstring vbp4k vbu4k vbu2k cdk_orig cdk4k str_only pread mmap_fn 17 | vbp1k 0.974/s -- -5% -6% -6% -7% -8% -8% -9% -10% -10% -11% -21% -24% -39% 18 | cdk2k 1.03/s 5% -- -1% -1% -2% -3% -3% -4% -5% -6% -7% -16% -20% -36% 19 | vbp2k 1.03/s 6% 1% -- -0% -1% -2% -3% -3% -4% -5% -6% -16% -19% -35% 20 | vbu1k 1.04/s 7% 1% 0% -- -0% -2% -2% -3% -4% -4% -6% -16% -19% -35% 21 | batio 1.04/s 7% 2% 1% 0% -- -2% -2% -2% -4% -4% -5% -15% -18% -35% 22 | bitstring 1.06/s 9% 3% 3% 2% 2% -- -0% -1% -2% -3% -4% -14% -17% -34% 23 | vbp4k 1.06/s 9% 3% 3% 2% 2% 0% -- -0% -2% -2% -4% -14% -17% -33% 24 | vbu4k 1.06/s 9% 4% 3% 3% 2% 1% 0% -- -1% -2% -3% -13% -17% -33% 25 | vbu2k 1.08/s 11% 5% 5% 4% 4% 2% 2% 1% -- -1% -2% -12% -15% -32% 26 | cdk_orig 1.09/s 12% 6% 5% 5% 4% 3% 3% 2% 1% -- -1% -12% -15% -32% 27 | cdk4k 1.10/s 13% 7% 6% 6% 6% 4% 4% 3% 2% 1% -- -10% -14% -31% 28 | str_only 1.23/s 26% 20% 19% 18% 18% 16% 16% 15% 14% 13% 12% -- -4% -23% 29 | pread 1.28/s 31% 25% 24% 23% 23% 21% 21% 20% 18% 18% 16% 4% -- -20% 30 | mmap_fn 1.59/s 64% 55% 54% 54% 53% 50% 50% 50% 47% 47% 45% 30% 25% -- 31 | -------------------------------------------------------------------------------- /src/batConcurrent.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Concurrent - Generic interface for concurrent operations 3 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | 22 | type lock = {execute : 'a 'b. ('a -> 'b) -> 'a -> 'b} 23 | 24 | let nolock= {execute = (fun f x -> f x)} 25 | 26 | let sync lock = lock.execute 27 | 28 | let synchronize locker f x = 29 | sync (locker ()) f x 30 | 31 | let compose {execute = a} {execute = b} = 32 | { 33 | execute = (fun f x -> b (a f) x) 34 | } 35 | 36 | let create ~enter ~leave = 37 | { 38 | execute = (fun f x -> 39 | enter (); 40 | try 41 | let result = f x in 42 | leave (); 43 | result 44 | with e -> 45 | leave (); 46 | raise e 47 | ) 48 | } 49 | 50 | 51 | module type BaseLock = 52 | sig 53 | type t (** The type of a lock. *) 54 | 55 | val create:unit -> t 56 | val lock : t -> unit 57 | val unlock:t -> unit 58 | val try_lock:t -> bool 59 | end 60 | 61 | 62 | module type Lock = 63 | sig 64 | type t (** The type of a lock. *) 65 | 66 | val create: unit -> t 67 | val lock : t -> unit 68 | val unlock: t -> unit 69 | val try_lock:t -> bool 70 | val synchronize: ?lock:t -> ('a -> 'b) -> 'a -> 'b 71 | 72 | val make : unit -> lock 73 | end 74 | 75 | let base_create = create 76 | 77 | module MakeLock(M:BaseLock) : Lock with type t = M.t = 78 | struct 79 | type t = M.t 80 | let create = M.create 81 | let lock = M.lock 82 | let unlock = M.unlock 83 | let try_lock=M.try_lock 84 | let synchronize ?(lock=M.create ()) f x = 85 | try 86 | M.lock lock; 87 | let result = f x in 88 | M.unlock lock; 89 | result 90 | with e -> M.unlock lock; 91 | raise e 92 | 93 | let make () = 94 | let lock = M.create () in 95 | base_create 96 | ~enter:(fun () -> M.lock lock) 97 | ~leave:(fun () -> M.unlock lock) 98 | 99 | end 100 | 101 | module BaseNoLock = struct 102 | type t = unit 103 | external create: unit -> t = "%ignore" 104 | external lock : t -> unit = "%ignore" 105 | external unlock: t -> unit = "%ignore" 106 | let try_lock _t = true 107 | end 108 | module NoLock = MakeLock(BaseNoLock) 109 | -------------------------------------------------------------------------------- /src/batFilename.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatFilename - Extended Filename module 3 | * Copyright (C) 1996 Xavier Leroy 4 | * 2008 David Teller, LIFO, Universite d'Orleans 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | include Filename 23 | 24 | ##V<4.4## let is_dir_sep name i = 25 | ##V<4.4## try 26 | ##V<4.4## for j = 0 to String.length dir_sep - 1 do 27 | ##V<4.4## if i + j >= String.length name || 28 | ##V<4.4## name.[i + j] != dir_sep.[j] then raise Exit 29 | ##V<4.4## done; 30 | ##V<4.4## true 31 | ##V<4.4## with Exit -> 32 | ##V<4.4## false 33 | ##V<4.4## 34 | ##V<4.4## let extension_len name = 35 | ##V<4.4## let rec check i0 i = 36 | ##V<4.4## if i < 0 || is_dir_sep name i then 0 37 | ##V<4.4## else if name.[i] = '.' then check i0 (i - 1) 38 | ##V<4.4## else String.length name - i0 39 | ##V<4.4## in 40 | ##V<4.4## let rec search_dot i = 41 | ##V<4.4## if i < 0 || is_dir_sep name i then 0 42 | ##V<4.4## else if name.[i] = '.' then check i (i - 1) 43 | ##V<4.4## else search_dot (i - 1) 44 | ##V<4.4## in 45 | ##V<4.4## search_dot (String.length name - 1) 46 | ##V<4.4## 47 | ##V<4.4## let remove_extension name = 48 | ##V<4.4## let l = extension_len name in 49 | ##V<4.4## if l = 0 then name else String.sub name 0 (String.length name - l) 50 | ##V<4.4## 51 | ##V<4.4## let extension name = 52 | ##V<4.4## let l = extension_len name in 53 | ##V<4.4## if l = 0 then "" else String.sub name (String.length name - l) l 54 | 55 | let split_extension s = 56 | remove_extension s, extension s 57 | 58 | (*$= split_extension & ~printer:(IO.to_string (Tuple2.print String.print String.print)) 59 | ("/foo/bar", ".baz") (split_extension "/foo/bar.baz") 60 | ("/foo/bar", "") (split_extension "/foo/bar") 61 | ("/foo/bar", ".") (split_extension "/foo/bar.") 62 | ("/foo/.rc", "") (split_extension "/foo/.rc") 63 | ("", "") (split_extension "") 64 | *) 65 | 66 | let with_temp_file ?temp_dir prfx sfx f = 67 | let tmp_fn = Filename.temp_file ?temp_dir prfx sfx in 68 | BatPervasives.finally (fun () -> Sys.remove tmp_fn) f tmp_fn 69 | 70 | (* the temp file is expected to exist during f's lifetime, but not after *) 71 | (*$T with_temp_file 72 | let fn = with_temp_file "batFilename_with_temp_file" ".tmp" \ 73 | (fun fn -> assert(Sys.file_exists fn); fn) in \ 74 | not (Sys.file_exists fn) 75 | *) 76 | -------------------------------------------------------------------------------- /src/batSplay.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Splay -- splay trees 3 | * Copyright (C) 2011 Batteries Included Development Team 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** Maps over ordered types based on splay trees. 22 | 23 | Splay trees are ordered binary trees that have the 24 | most recently used element as the root of the tree. 25 | If another element is accessed (even read-only), 26 | the tree will be rearranged internally. 27 | 28 | Not threadsafe; even read-only functions will rearrange 29 | the tree, even though its contents will remain unchanged. 30 | *) 31 | 32 | module Map (Ord : BatInterfaces.OrderedType) 33 | : sig 34 | include BatMap.S with type key = Ord.t 35 | 36 | (* Redeclare operations to remove incorrect physical equality documentation. *) 37 | 38 | val add: key -> 'a -> 'a t -> 'a t 39 | (** [add x y m] returns a map containing the same bindings as 40 | [m], plus a binding of [x] to [y]. If [x] was already bound 41 | in [m], its previous binding disappears. *) 42 | 43 | val update_stdlib : key -> ('a option -> 'a option) -> 'a t -> 'a t 44 | (** [update_stdlib k f m] returns a map containing the same bindings as [m], 45 | except [k] has a new binding as determined by [f]: 46 | First, calculate [y] as [f (find_opt k m)]. 47 | If [y = Some v] then [k] will be bound to [v] in the resulting map. 48 | Else [k] will not be bound in the resulting map. 49 | 50 | This function does the same thing as [update] in the stdlib, but has a 51 | different name for backwards compatibility reasons. 52 | 53 | @since 3.3.0 *) 54 | 55 | val remove: key -> 'a t -> 'a t 56 | (** [remove x m] returns a map containing the same bindings as 57 | [m], except for [x] which is unbound in the returned map. *) 58 | 59 | val filter: (key -> 'a -> bool) -> 'a t -> 'a t 60 | (** [filter f m] returns a map where only the [(key, value)] pairs of [m] 61 | such that [f key value = true] remain. The bindings are passed to 62 | [f] in increasing order with respect to the ordering over the type 63 | of the keys. *) 64 | 65 | val print_as_list: 66 | ('a BatInnerIO.output -> key -> unit) -> 67 | ('a BatInnerIO.output -> 'c -> unit) -> 68 | 'a BatInnerIO.output -> 'c t -> unit 69 | val of_list : (Ord.t * 'a) list -> 'a t 70 | val to_list : 'a t -> (Ord.t * 'a) list 71 | end 72 | -------------------------------------------------------------------------------- /benchsuite/array_partition.ml: -------------------------------------------------------------------------------- 1 | let (|>) x f = f x 2 | 3 | let list_partition p a = 4 | let left, right = Array.to_list a |> List.partition p in 5 | Array.of_list left, Array.of_list right 6 | 7 | open Array 8 | let current_partition p xs = 9 | let n = length xs in 10 | (* Use a bitset to store which elements will be in which final array. *) 11 | let bs = BatBitSet.create n in 12 | for i = 0 to n-1 do 13 | if p xs.(i) then BatBitSet.set bs i 14 | done; 15 | (* Allocate the final arrays and copy elements into them. *) 16 | let n1 = BatBitSet.count bs in 17 | let n2 = n - n1 in 18 | let j = ref 0 in 19 | let xs1 = init n1 20 | (fun _ -> 21 | (* Find the next set bit in the BitSet. *) 22 | while not (BatBitSet.mem bs !j) do incr j done; 23 | let r = xs.(!j) in 24 | incr j; 25 | r) in 26 | let j = ref 0 in 27 | let xs2 = init n2 28 | (fun _ -> 29 | (* Find the next clear bit in the BitSet. *) 30 | while BatBitSet.mem bs !j do incr j done; 31 | let r = xs.(!j) in 32 | incr j; 33 | r) in 34 | xs1, xs2 35 | 36 | let unixjunkie_partition p a = 37 | let n = length a in 38 | if n = 0 then ([||], [||]) 39 | else 40 | let mask = make n false in 41 | let ok_count = ref 0 in 42 | iteri (fun i x -> 43 | if p x then 44 | (unsafe_set mask i true; 45 | incr ok_count) 46 | ) a; 47 | let ko_count = n - !ok_count in 48 | let init = unsafe_get a 0 in 49 | let ok = make !ok_count init in 50 | let ko = make ko_count init in 51 | let j = ref 0 in 52 | let k = ref 0 in 53 | iteri (fun i px -> 54 | let x = unsafe_get a i in 55 | if px then 56 | (unsafe_set ok !j x; 57 | incr j) 58 | else 59 | (unsafe_set ko !k x; 60 | incr k) 61 | ) mask; 62 | (ok, ko) 63 | 64 | let gasche_partition p xs = 65 | let n = length xs in 66 | if n = 0 then ([||], [||]) else begin 67 | let size_yes = ref 0 in 68 | let bs = Array.init n (fun i -> 69 | let b = p (unsafe_get xs i) in 70 | if b then incr size_yes; 71 | b) in 72 | let yes = Array.make !size_yes xs.(0) in 73 | let no = Array.make (n - !size_yes) xs.(0) in 74 | let iyes = ref 0 in 75 | let ino = ref 0 in 76 | for i = 0 to n - 1 do 77 | if (unsafe_get bs i) then begin 78 | unsafe_set yes !iyes (unsafe_get xs i); 79 | incr iyes; 80 | end else begin 81 | unsafe_set no !ino (unsafe_get xs i); 82 | incr ino; 83 | end 84 | done; 85 | yes, no 86 | end 87 | 88 | let input_gen n = Array.init (1000 * n) (fun x -> x) 89 | 90 | let m4 = fun x -> x mod 4 = 0 91 | let m5 = fun x -> x mod 5 = 0 92 | let m10 = fun x -> x mod 10 = 0 93 | 94 | let () = 95 | Bench.config.Bench.samples <- 1000; 96 | Bench.config.Bench.gc_between_tests <- true; 97 | Bench.bench_n [ 98 | "list_partition", 99 | (fun a -> list_partition m4 (input_gen a)); 100 | "current_partition", 101 | (fun a -> current_partition m4 (input_gen a)); 102 | "unixjunkie_partition", (fun a -> unixjunkie_partition m4 (input_gen a)); 103 | "gasche_partition", (fun a -> gasche_partition m4 (input_gen a)); 104 | ] |> Bench.summarize ~alpha:0.05 105 | -------------------------------------------------------------------------------- /src/batUChar.mli: -------------------------------------------------------------------------------- 1 | (** Unicode characters. 2 | 3 | This module implements Unicode characters. 4 | *) 5 | 6 | (* Copyright (C) 2002, 2003, 2004, 2011 Yamagata Yoriyuki. *) 7 | 8 | (* This library is free software; you can redistribute it and/or *) 9 | (* modify it under the terms of the GNU Lesser General Public License *) 10 | (* as published by the Free Software Foundation; either version 2 of *) 11 | (* the License, or (at your option) any later version. *) 12 | 13 | (* As a special exception to the GNU Library General Public License, you *) 14 | (* may link, statically or dynamically, a "work that uses this library" *) 15 | (* with a publicly distributed version of this library to produce an *) 16 | (* executable file containing portions of this library, and distribute *) 17 | (* that executable file under terms of your choice, without any of the *) 18 | (* additional requirements listed in clause 6 of the GNU Library General *) 19 | (* Public License. By "a publicly distributed version of this library", *) 20 | (* we mean either the unmodified Library as distributed by the authors, *) 21 | (* or a modified version of this library that is distributed under the *) 22 | (* conditions defined in clause 3 of the GNU Library General Public *) 23 | (* License. This exception does not however invalidate any other reasons *) 24 | (* why the executable file might be covered by the GNU Library General *) 25 | (* Public License . *) 26 | 27 | (* This library is distributed in the hope that it will be useful, *) 28 | (* but WITHOUT ANY WARRANTY; without even the implied warranty of *) 29 | (* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *) 30 | (* Lesser General Public License for more details. *) 31 | 32 | (* You should have received a copy of the GNU Lesser General Public *) 33 | (* License along with this library; if not, write to the Free Software *) 34 | (* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 *) 35 | (* USA *) 36 | 37 | (* You can contact the authour by sending email to *) 38 | (* yori@users.sourceforge.net *) 39 | 40 | type t 41 | 42 | exception Out_of_range 43 | 44 | (** [char_of u] returns the Latin-1 representation of [u]. 45 | If [u] can not be represented by Latin-1, raises Out_of_range *) 46 | val char_of : t -> char 47 | 48 | (** [of_char c] returns the Unicode character of the Latin-1 character [c] *) 49 | val of_char : char -> t 50 | 51 | (** [code u] returns the Unicode code number of [u]. *) 52 | external code : t -> int = "%identity" 53 | 54 | (** [chr n] returns the Unicode character with the code number [n]. 55 | If n does not lay in the valid range of Unicode or designates a 56 | surrogate character, raises Out_of_range *) 57 | val chr : int -> t 58 | 59 | (** Equality by code point comparison *) 60 | val eq : t -> t -> bool 61 | 62 | (** [compare u1 u2] returns, 63 | a value > 0 if [u1] has a larger Unicode code number than [u2], 64 | 0 if [u1] and [u2] are the same Unicode character, 65 | a value < 0 if [u1] has a smaller Unicode code number than [u2]. *) 66 | val compare : t -> t -> int 67 | 68 | (** Aliases of [type t] *) 69 | type uchar = t 70 | 71 | (** Alias of [code] *) 72 | val int_of : uchar -> int 73 | 74 | (** Alias of [chr] *) 75 | val of_int : int -> uchar 76 | 77 | (** [true] if the char is a regular ascii char, i.e. if its code is <= 127 78 | @since 2.2.0 *) 79 | val is_ascii : uchar -> bool 80 | 81 | (**/**) 82 | 83 | val unsafe_chr : int -> t 84 | 85 | (**/**) 86 | -------------------------------------------------------------------------------- /src/batDigest.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * BatDigest - Additional functions for message digests 3 | * Copyright (C) 1996 Xavier Leroy, INRIA Rocquencourt 4 | * Copyright (C) 2009 David Teller, LIFO, Universite d'Orleans 5 | * 6 | * This library is free software; you can redistribute it and/or 7 | * modify it under the terms of the GNU Lesser General Public 8 | * License as published by the Free Software Foundation; either 9 | * version 2.1 of the License, or (at your option) any later version, 10 | * with the special exception on linking described in file LICENSE. 11 | * 12 | * This library is distributed in the hope that it will be useful, 13 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15 | * Lesser General Public License for more details. 16 | * 17 | * You should have received a copy of the GNU Lesser General Public 18 | * License along with this library; if not, write to the Free Software 19 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | include Digest 23 | 24 | (*$inject 25 | ##V>=5##module Pervasives = Stdlib 26 | *) 27 | 28 | (*Imported from [Digest.input] -- the functions used take advantage of 29 | [BatIO.input] rather than [in_channel]*) 30 | let input inp = BatIO.really_nread inp 16 31 | (*$T 32 | let digest = Digest.string "azerty" in \ 33 | input (BatIO.input_string digest) = digest 34 | *) 35 | 36 | let output = BatIO.nwrite 37 | let print oc t = BatIO.nwrite oc (to_hex t) 38 | 39 | let channel inp len = (*TODO: Make efficient*) 40 | if len >= 0 41 | then Digest.string (BatIO.really_nread inp len) 42 | else Digest.channel (BatIO.to_input_channel inp) len 43 | (*$T 44 | let digest = Digest.string "azerty" in \ 45 | channel (BatIO.input_string ("azertyuiop")) 6 = digest 46 | *) 47 | 48 | (*1. Compute the digest of this file using Legacy.Digest*) 49 | (*2. Compute the digest of this file using Batteries.Digest*) 50 | (*3. Compare*) 51 | (*$R channel 52 | let legacy_result () = 53 | let inp = Legacy.open_in_bin Sys.argv.(0) in 54 | let result = Legacy.Digest.channel inp (-1) in 55 | Legacy.close_in inp; 56 | result 57 | in 58 | let batteries_result () = 59 | let inp = BatFile.open_in Sys.argv.(0) in 60 | let result = channel inp (-1) in 61 | BatIO.close_in inp; 62 | result 63 | in 64 | assert_equal ~printer:(Printf.sprintf "%S") 65 | (legacy_result ()) (batteries_result ()) 66 | *) 67 | 68 | let from_hex s = 69 | if String.length s <> 32 then invalid_arg "Digest.from_hex"; 70 | let digit c = 71 | match c with 72 | | '0'..'9' -> Char.code c - Char.code '0' 73 | | 'A'..'F' -> Char.code c - Char.code 'A' + 10 74 | | 'a'..'f' -> Char.code c - Char.code 'a' + 10 75 | | _ -> invalid_arg "Digest.from_hex" 76 | in 77 | let byte i = digit s.[i] lsl 4 + digit s.[i+1] in 78 | BatBytesCompat.string_init 16 (fun i -> Char.chr (byte (2 * i))) 79 | 80 | (*$Q 81 | Q.string (fun s -> \ 82 | let h = string s in h |> to_hex |> from_hex = h) 83 | *) 84 | 85 | let compare = String.compare 86 | 87 | ##V<4.2##let bytes = string 88 | ##V<4.2##let subbytes = substring 89 | 90 | ##V<4.3##let equal d1 d2 = (compare d1 d2 = 0) 91 | (*$T 92 | equal (string "foo") (string "foo") 93 | equal (string "") (string "") 94 | not @@ equal (string "foo") (string "bar") 95 | not @@ equal (string "foo") (string "foo\000") 96 | not @@ equal (string "foo") (string "") 97 | *) 98 | -------------------------------------------------------------------------------- /src/batInterfaces.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Interfaces - Common interfaces for data structures 3 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** 22 | Common signatures for data structures. 23 | *) 24 | 25 | 26 | (** A signature for data structures which have a 27 | [map : ('a -> 'b) -> ('a t -> 'b t)] operation. 28 | 29 | If you create a new data structure, you should make it compatible 30 | with [Mappable]. 31 | *) 32 | module type Mappable = sig 33 | type 'a mappable (** The data structure, e.g. ['a List.t] *) 34 | 35 | val map : ('a -> 'b) -> ('a mappable -> 'b mappable) 36 | (** [map f e] applies [f] to every element of [e] and returns the corresponding data structure *) 37 | end 38 | 39 | module type OrderedType = 40 | sig 41 | type t 42 | val compare : t -> t -> int 43 | (** A total ordering function 44 | This is a two-argument function [f] such that 45 | [f e1 e2] is zero if the values [e1] and [e2] are equal, 46 | [f e1 e2] is strictly negative if [e1] is smaller than [e2], 47 | and [f e1 e2] is strictly positive if [e1] is greater than [e2]. 48 | Example: a suitable ordering function is the generic structural 49 | comparison function {!Pervasives.compare}. *) 50 | end 51 | 52 | (** Monads are a design pattern which may be used to enforce strong 53 | functional or non-functional constraints on the manipulation of 54 | resources, while remaining in the world of functional programming. 55 | For instance, monads may serve to implement approximations of a 56 | types-and-effects type system, to enforce functional use of arrays 57 | or other mutable data structures, or to enforce the fact that only 58 | files opened for writing may be actually used for writing. 59 | 60 | For more information on monads, see 61 | {{:http://enfranchisedmind.com/blog/2007/08/06/a-monad-tutorial-for-ocaml/} 62 | A Monad Tutorial for Ocaml}. 63 | 64 | This definition is compatible with the standard syntax extension 65 | for monads. For more information, see 66 | {{:http://www.cas.mcmaster.ca/~carette/pa_monad/} the 67 | documentation of pa_monad}. 68 | 69 | @author David Teller 70 | *) 71 | 72 | (** Signature for monads *) 73 | module type Monad = sig 74 | 75 | (** The type of a monad producing values of type ['a].*) 76 | type 'a m 77 | 78 | (** Monadic binding. 79 | 80 | [bind m f] executes first [m] then [f], using the 81 | result of [m]. *) 82 | val bind : 'a m -> ('a -> 'b m) -> 'b m 83 | 84 | (**Return a value, that is, put a value in the monad.*) 85 | val return: 'a -> 'a m 86 | 87 | end 88 | -------------------------------------------------------------------------------- /src/batConcurrent.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Concurrent - Generic interface for concurrent operations 3 | * Copyright (C) 2008 David Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** 22 | Definition of concurrency primitives. 23 | 24 | @author David Teller 25 | *) 26 | 27 | type lock 28 | (** The light-weight type of a lock, i.e. a construction which may be 29 | used to guarantee that a section will not be interrupted by 30 | another thread. 31 | 32 | This light-weight type is independent of the underlying locking 33 | mechanism and can be used if you do not know whether your code 34 | will run with vmthreads, Posix threads, coThreads, etc. 35 | *) 36 | 37 | val create: enter:(unit -> unit) -> leave:(unit -> unit) -> lock 38 | (** Create a lock from a pair of locking/unlocking functions 39 | 40 | @param enter Enter critical section. 41 | @param leave Leave critical section. 42 | .*) 43 | 44 | val nolock : lock 45 | (** A lock which does nothing.*) 46 | 47 | val synchronize: (unit -> lock) -> ('a -> 'b) -> 'a -> 'b 48 | (** 49 | [synchronize locker f] returns a function [f'] which behaves as 50 | [f] but whose executions are protected by one lock obtained from 51 | [locker]. The same lock will be reused for all subsequent uses of 52 | [f']. 53 | 54 | For instance, 55 | [synchronize Mutex.make f] is a new function whose executions 56 | will by synchronized by a new lock. Conversely, 57 | [synchronize (const my_lock) f] is a new function whose executions 58 | will be synchronized by an existing lock [my_lock]. 59 | *) 60 | 61 | val sync:lock -> ('a -> 'b) -> 'a -> 'b 62 | (** 63 | Specialized version of [synchronized]. 64 | 65 | [sync lock f] behaves as [synchronize (const lock) f] but slightly faster 66 | *) 67 | 68 | val compose : lock -> lock -> lock 69 | (** 70 | Compose two lock systems into a third lock system. 71 | *) 72 | 73 | 74 | 75 | (** A signature for modules which implement locking.*) 76 | module type BaseLock = 77 | sig 78 | type t(**The type of a lock.*) 79 | 80 | val create:unit -> t 81 | val lock : t -> unit 82 | val unlock:t -> unit 83 | val try_lock:t -> bool 84 | end 85 | 86 | 87 | module type Lock = 88 | sig 89 | type t(**The type of a lock.*) 90 | 91 | val create: unit -> t 92 | val lock : t -> unit 93 | val unlock: t -> unit 94 | val try_lock:t -> bool 95 | 96 | val synchronize: ?lock:t -> ('a -> 'b) -> 'a -> 'b 97 | 98 | val make : unit -> lock 99 | end 100 | 101 | module MakeLock(M:BaseLock) : Lock with type t = M.t 102 | 103 | module NoLock : Lock 104 | 105 | -------------------------------------------------------------------------------- /toplevel/battop.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Top - An interpreted preamble for the toplevel 3 | * Copyright (C) 2009 David Rajchenbach-Teller, LIFO, Universite d'Orleans 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** 22 | This file is meant to be invoked by a toplevel and performs initialization 23 | of OCaml Batteries Included and its libraries. 24 | 25 | Initialization consists of 26 | - loading Findlib 27 | - loading dependencies 28 | - loading the contents of the on-line help system 29 | - printing a welcome message 30 | 31 | This file is loaded by the magic line in the ocamlinit file. 32 | *) 33 | 34 | 35 | (* END CONFIGURATION *) 36 | 37 | (* MUST BE ALREADY HANDLED BY .ocamlinit 38 | #use "topfind";; 39 | *) 40 | #thread;; 41 | #require "batteries";; 42 | 43 | 44 | if !Sys.interactive then (*Only initialize help and display welcome if we're in interactive mode.*) 45 | begin 46 | BatteriesHelp.init (); 47 | let ver = BatteriesConfig.version in 48 | let vlen = String.length ver in 49 | let pad = String.make vlen '_' in 50 | let pad2 = String.make vlen ' ' in 51 | print_endline (" ___________________"^ pad ^"_______"); 52 | print_endline (" [| + | | Batteries " ^ ver ^ " - |"); 53 | print_endline (" |_____|_|___________"^ pad ^"______|"); 54 | print_endline (" ___________________"^ pad ^"_______"); 55 | print_endline (" | - Type '#help;;' "^ pad2 ^"| | + |]"); 56 | print_endline (" |___________________"^ pad ^"|_|___|"); 57 | print_newline (); 58 | print_newline (); 59 | flush_all () 60 | end;; 61 | 62 | open Batteries;; 63 | #install_printer BatteriesPrint.print_uchar;; 64 | #install_printer BatteriesPrint.print_ustring;; 65 | #install_printer BatteriesPrint.print_rope;; 66 | (* 67 | #install_printer BatteriesPrint.print_string_cap_rw;; 68 | #install_printer BatteriesPrint.print_string_cap_ro;; 69 | *) 70 | #install_printer BatteriesPrint.string_dynarray;; 71 | #install_printer BatteriesPrint.int_dynarray;; 72 | #install_printer BatteriesPrint.char_dynarray;; 73 | #install_printer BatteriesPrint.float_dynarray;; 74 | #install_printer BatteriesPrint.int_set;; 75 | #install_printer BatteriesPrint.int32_set;; 76 | #install_printer BatteriesPrint.int64_set;; 77 | #install_printer BatteriesPrint.natint_set;; 78 | #install_printer BatteriesPrint.float_set;; 79 | #install_printer BatteriesPrint.string_set;; 80 | #install_printer BatteriesPrint.int_pset;; 81 | #install_printer BatteriesPrint.string_pset;; 82 | #install_printer BatteriesPrint.rope_pset;; 83 | #install_printer BatteriesPrint.char_pset;; 84 | #install_printer BatteriesPrint.int_enum;; 85 | #install_printer BatteriesPrint.string_enum;; 86 | #install_printer BatteriesPrint.rope_enum;; 87 | #install_printer BatteriesPrint.char_enum;; 88 | -------------------------------------------------------------------------------- /src/batHashcons.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Hashcons -- a hashconsing library 3 | * Copyright (C) 2011 Batteries Included Development Team 4 | * 5 | * This library is free software; you can redistribute it and/or 6 | * modify it under the terms of the GNU Lesser General Public 7 | * License as published by the Free Software Foundation; either 8 | * version 2.1 of the License, or (at your option) any later version, 9 | * with the special exception on linking described in file LICENSE. 10 | * 11 | * This library is distributed in the hope that it will be useful, 12 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 14 | * Lesser General Public License for more details. 15 | * 16 | * You should have received a copy of the GNU Lesser General Public 17 | * License along with this library; if not, write to the Free Software 18 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | (** Hash consing of data structures *) 22 | 23 | (** The type [t hobj] represents hashed objects of type [t]. A hashed 24 | object contains a unique tag and a hash code. *) 25 | type 'a hobj = private { 26 | obj : 'a ; 27 | tag : int ; (** Unique id for this object *) 28 | hcode : int ; (** Hash code for this object *) 29 | } 30 | 31 | type 'a t = 'a hobj 32 | (** A synonym for convenience *) 33 | 34 | val compare : 'a hobj -> 'a hobj -> int 35 | (** Comparison on the tags *) 36 | 37 | (** Hashcons tables *) 38 | module type Table = sig 39 | type key 40 | (** type of objects in the table *) 41 | 42 | type t 43 | (** type of the table *) 44 | 45 | val create : int -> t 46 | (** [create n] creates a table with at least [n] cells. *) 47 | 48 | val clear : t -> unit 49 | (** [clear tab] removes all entries from the table [tab]. *) 50 | 51 | val hashcons : t -> key -> key hobj 52 | (** [hashcons tab k] returns either [k], adding it to the table 53 | [tab] as a side effect, or if [k] is already in the table then 54 | it returns the hashed object corresponding to that entry. 55 | @raise Failure if number of objects with the same hash reaches system limit of array size *) 56 | 57 | val iter : (key hobj -> unit) -> t -> unit 58 | (** [iter f tab] applies [f] to every live hashed object in the 59 | table [tab]. *) 60 | 61 | val fold : (key hobj -> 'a -> 'a) -> t -> 'a -> 'a 62 | (** [fold f tab x0] folds [f] across every live hashed object in 63 | the table [tab], starting with value [x0] *) 64 | 65 | val count : t -> int 66 | (** [count tab] returns a count of how many live objects are in 67 | [tab]. This can decrease whenever the GC runs, even during 68 | execution, so consider the returned value as an upper-bound. *) 69 | end 70 | 71 | module MakeTable (HT : BatHashtbl.HashedType) 72 | : Table with type key = HT.t 73 | 74 | (** Hashing utilities *) 75 | module H : sig 76 | val hc0_ : int -> int 77 | (** [hc0_ h] corresponds to the hashcode of a first constructor 78 | applied to an object of hashcode [h] *) 79 | 80 | val hc0 : 'a hobj -> int 81 | (** [hc0 ho] is the hashcode of a first constructor applied to the 82 | hashed object [ho] *) 83 | 84 | val hc1_ : int -> int -> int 85 | (** [hc1_ h k] corresponds to the hashcode of the [k]th 86 | constructor applied to an object of hashcode [h]. *) 87 | 88 | val hc1 : 'a hobj -> int -> int 89 | (** [hc1 ho k] corresponds to the hashcode of the [k]th 90 | constructor applied to the hashed object [ho]. *) 91 | end 92 | -------------------------------------------------------------------------------- /src/batRMutex.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * RMutex - Reentrant mutexes 3 | * Copyright (C) 1996 Xavier Leroy 4 | * 1996 Damien Doligez 5 | * 2008 David Teller 6 | * 7 | * This library is free software; you can redistribute it and/or 8 | * modify it under the terms of the GNU Lesser General Public 9 | * License as published by the Free Software Foundation; either 10 | * version 2.1 of the License, or (at your option) any later version, 11 | * with the special exception on linking described in file LICENSE. 12 | * 13 | * This library is distributed in the hope that it will be useful, 14 | * but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 16 | * Lesser General Public License for more details. 17 | * 18 | * You should have received a copy of the GNU Lesser General Public 19 | * License along with this library; if not, write to the Free Software 20 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 21 | *) 22 | 23 | 24 | (** Reentrant Mutexes 25 | 26 | Mutexes (mutual-exclusion locks) are used to implement critical sections 27 | and protect shared mutable data structures against concurrent accesses. 28 | The typical use is (if [m] is the mutex associated with the data structure 29 | [D]): 30 | {[ 31 | RMutex.synchronize ~lock:m (fun () -> 32 | (* Critical section that operates over D *); 33 | ) () 34 | ]} 35 | 36 | This module implements reentrant mutexes, i.e. a version of mutexes which 37 | may be locked again by their owner thread without blocking this thread. 38 | Reentrant mutexes are typically slower than regular mutexes but also safer. 39 | 40 | @documents RMutex 41 | 42 | @author Xavier Leroy (Base module) 43 | @author Damien Doligez (Base module) 44 | @author David Teller 45 | *) 46 | 47 | type t 48 | (** The type of mutexes. *) 49 | 50 | val create : unit -> t 51 | (** Return a new mutex. *) 52 | 53 | val lock : t -> unit 54 | (** Lock the given mutex. Only one thread can have the mutex locked 55 | at any time. A thread that attempts to lock a mutex already locked 56 | will suspend until the other mutex is unlocked. 57 | 58 | {b Note} attempting to lock a mutex you already have locked from 59 | the same thread will not suspend your thread. 60 | *) 61 | 62 | val try_lock : t -> bool 63 | (** Same as {!RMutex.lock}, but does not suspend the calling thread if 64 | the mutex is already locked: just return [false] immediately 65 | in that case. If the mutex is unlocked, lock it and 66 | return [true]. *) 67 | 68 | val unlock : t -> unit 69 | (** Unlock the given mutex. Other threads suspended trying to lock 70 | the mutex will restart. If the mutex wasn't locked, nothing happens.*) 71 | 72 | val synchronize : ?lock:t -> ('a -> 'b) -> 'a -> 'b 73 | (** Protect a function. 74 | 75 | [synchronize f] returns a new function [f'] with the same behavior 76 | as [f] but such that concurrenty calls to [f'] are queued if 77 | necessary to avoid races. 78 | 79 | [synchronize ~lock:l f] behaves as [synchronize f] but uses a 80 | user-specified lock [l], which may be useful to share a lock 81 | between several function. 82 | 83 | In either case, the lock is acquired when entering the function 84 | and released when the function call ends, whether this is due 85 | to normal termination or to some exception being raised. 86 | *) 87 | 88 | 89 | val make : unit -> BatConcurrent.lock 90 | (** 91 | Create a new abstract lock based on Reentrant Mutexes. 92 | *) 93 | --------------------------------------------------------------------------------