pax_global_header00006660000000000000000000000064125646116450014524gustar00rootroot0000000000000052 comment=5def7c88701cdd5235cfbaa6edb57113b688552c core_kernel-113.00.00/000077500000000000000000000000001256461164500143165ustar00rootroot00000000000000core_kernel-113.00.00/CHANGES.md000066400000000000000000001650541256461164500157230ustar00rootroot00000000000000## 113.00.00 - Added `Float.int63_round_nearest_exn`. val int63_round_nearest_exn : t -> Core_int63. - Changed `Hashtbl.sexp_of_t` so that keys are sorted in increasing order. This also applies to the `sexp_of_t` produced by `Hashtbl.Make` and `Make_binable`. Sorting by key is nice when looking at output, as well as in tests, so that the output is deterministic and so that diffs are minimized when output changes. - Added to `Info`, `Error`, and `Or_error` a `Stable.V2` module, whose `bin_io` is the same as the unstable `bin_io`. - Replaced `Map.prev_key` and `next_key` with `closest_key`. val closest_key : ('k, 'v, 'cmp) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'k -> ('k * 'v) option - Shared code between `Monad.Make{,2}` and `Applicative.Make{,2}`. - Added tests to make sure `round_nearest` and `int63_round_nearest_exn` don't allocate. - Added `Lazy.T_unforcing` module, with a custom `sexp_of_t` that doesn't force. This serializer does not support round tripping, i.e. `t_of_sexp`. It is intended to be used in debug code or `<:sexp_of< >>` statements. E.g: type t = { x : int Lazy.T_unforcing.t ; y : string } with sexp_of - Extended `Map.to_sequence` and `Set.to_sequence` to take any combination of upper bound, lower bound, and direction. - Added `Map.split`. - Added `Timing_wheel.fire_past_alarms`, which fires alarms in the current time interval's bucket whose time is in the past. - Added a `Total_map` module, for maps where every value of the key type is present in the map. - Added `Bigstring.compare` and `Bigstring.equal`. - Split `monad.ml` into three files: `monad.ml`, `monad.mli`, and `monad_intf.ml`. - Removed the last remaining dependence of `Core_kernel` on Unix, moving `Time_ns.pause` functions to `Core`. - Added optional arguments to `Hash_queue.create`, `?growth_allowed` and `size`, which then get passed to `Hashtbl.create`. - Added a `?strict:unit` argument to functions that ordinarily create lazy sexps, like `failwiths`. Info.create Error.create Error.failwiths Error.failwithp Or_error.error This makes it easy to force a use to be strict, which is sometimes useful to accurately capture the state of a mutable data structure at the time the error happens, lest it change by the time the error is rendered. - Removed `Interned_string` module. - In `Pooled_hashtbl`, avoid trying to create arrays bigger than `Sys.max_array_length`. The problem affected 32-bit platforms. - Added `Quickcheck` module. Supports automated testing with randomly-generated inputs in the style of Haskell's Quickcheck library. Our adaptation supports flexible probability distributions for values of a given type and uniqueness guarantees for generated values. - Made `Set.to_sequence` and `Set.split` have the same interface as `Map.to_sequence` and `Map.split`, respectively. - Fixed `Float` and `Timing_wheel` to compile on 32-bit platforms. - Added `Lazy.Stable.V1`. - Added `List.reduce_balanced`, which is like `reduce`, but relies on associativity of `f` to make nesting of calls to `f` logarithmic rather than linear in the input list length. - Added `String_id.Make_without_pretty_printer`. - Restricted `Time_ns.Span` values to be less than 135 years, which ensures the corresponding `float` `Time.Span` values have microsecond precision. Fixed a `Time_ns` test that recently started failing due to crossing the 135-year boundary. Reducing the range of `Time_ns.Span` required adjusting the implementation of `Core.Time_ns.Option.Stable.V1`, which (accidentally, incorrectly) incorporated the (unstabilized) `Core_kernel.Time_ns.Span.min_value` as the representation of `bid_none` and `.max_value` as `ask_none`. The prior representation is preserved, but some previously allowed values are no longer allowed and now raise exceptions! - Added `Rope` module, the standard data structure for efficient string manipulation. - Added `Sequence.unfold_with_and_finish`, a variant of `unfold_with` that can continue the sequence after the inner sequence finishes. - Replaced `Sequence.cycle` with `Sequence.cycle_list_exn`, to work around a bug in `Sequence.cycle` raising on the empty sequence. Sequence.cycle can cause an infinite loop if its input is empty. It is problematic to check whether the input sequence is empty. * If we check it eagerly, we have to turn `cycle` into `cycle_eagerly_exn`, and it will evaluate the first element twice. * If we check it lazily, we might raise an exception in a seemingly unrelated part of the code, and the usually-good habit of wrapping a function like `cycle_exn` in `try .. with ..` would not catch it. To get around these issues, [cycle] is changed to accept only lists as inputs, not sequences. It is now called [cycle_list_exn]. - Fixed assumptions about the size of integers, to support compiling to Javascript, where integers are 32-bit. - Fixed build on Mac OSX. Fix build when LINUX_EXT or TIMERFD are undefined. - Added `Caml.Bytes`. Add an alias for Bytes in Caml. Fixes janestreet/core_kernel#46. - In `Container`, exposed polymorphic functions individually building container functions using `fold` or `iter`. Exposed polymorphic functions in `Core_kernel.Container` for individually building each of the `Container` functions using `fold` or `iter`. E.g.: type ('t, 'elt, 'accum) fold = 't -> init:'accum -> f:('accum -> 'elt -> 'accum) -> 'accum type ('t, 'elt) iter = 't -> f:('elt -> unit) -> unit val length : fold:('t, _, int ) fold -> 't -> int val exists : iter:('t, 'a) iter -> 't -> f:('a -> bool) -> bool - Added container.mli, which was sorely missing. - Added `Doubly_linked.to_sequence`. - Added `Hash_queue.sexp_of_t`. ## 112.35.00 - Added an Applicative interface to Core (a.k.a. idioms or applicative functors) - Generalized the signature of `Hashtbl.merge_into` to allow the types of `src` and `dst` to be different. - Made `Day_of_week.of_string` accept additional formats (integers 0-6, full day names). - Added `Day_of_week.to_string_long`, which produces the full day name. - Changed `Hashtbl.add_exn` to not create a new exception constructor when it raises due to a duplicate key. - Added `Map.nth`, which returns the nth element of a map, ordered by key rank. - Added `Binable.Of_binable` functors, similar to `Sexpable.Of_sexpable` One should use `Binable.Of_binable` rather than the functionally equivalent `Bin_prot.Utils.Make_binable`. - Added `Either` module, with `type ('a, 'b) t = First of 'a | Second of 'b`. - Added to `Univ_map` a functor that creates a new `Univ_map` type in which the type of data is a function of the key's type, with the type function specified by the functor's argument. Normally, a `Univ_map.t` stores `('a Key.t * 'a)` pairs. This feature lets it store `('a Key.t * 'a Data.t)` pairs for a given `('a Data.t)`. - Made `Day_of_week.Stable` be `Comparable` and `Hashable`. - Fixed a couple `Exn` unit tests that mistakenly relied on the global setting of `Printexc.get_backtrace`. Now the tests locally set it to what they need. This avoids unit-test failures when running with no `OCAMLRUNPARAM` set: File "exn.ml", line 130, characters 2-258: clear_backtrace threw "Assert_failure exn.ml:133:4". in TEST_MODULE at file "exn.ml", line 127, characters 0-1057 - Renamed `Monad.ignore` as `Monad.ignore_m`, while preserving `ignore = ignore_m` in existing modules (e.g. `Deferred`) that used it. We can later consider those modules on a case-by-case basis to see whether we want to remove `ignore`. - Added `Set.symmetric_diff`. - Added `Timing_wheel.reschedule`, which reschedules an existing alarm. - Added `Applicative.S2`, analogous to `Monad.S2`. - Added combinators to `Either`. - Added `Hashtbl.add_or_error` and `create_with_key_or_error`, which use `Or_error` and are more idiomatic ways of signalling duplicates. - Added `Sexpable.Of_sexpable1` functor, for one-parameter type constructors. - Made `Timing_wheel_ns` keys be `Int63.t` rather than `int`, so that behavior is consistent on 32-bit and 64-bit machines. Also, made `Timing_wheel.Interval_num` an abstract type. - Hid the `bytes` type in `Core.Std`, so that type errors refer to `string` rather than `bytes`. Added `Bytes` module so that people can say `Bytes.t` if they need to. Now we get reasonable error messages: String.length 13 --> Error: This expression has type int but an expression was expected of type string "" + 13 --> Error: This expression has type string but an expression was expected of type int - Modernized the coding style in `Timing_wheel`. - Replaced `Unpack_buffer.unpack` with `unpack_into` and `unpack_iter`, to avoid allocation. `Unpack_buffer.unpack` created a (vector-backed) `Core.Std.Queue` for each call. When unpacking a buffer containing many values, resizing of the buffer can be costly and in some cases leads to promotions of short-lived data to the major heap. The new functions avoid allocating the queue: val unpack_into : ('value, _) t -> 'value Queue.t -> unit Or_error.t val unpack_iter : ('value, _) t -> f:('value -> unit) -> unit Or_error.t - Cleaned up the implementation of `Gc.tune`. - Change `Unit` implementation to use `Identifiable.Make` instead of applying functors separately. - Added `val random: unit -> int` to `Int63`. - Reworked `Float.iround_*_exn` functions to not allocate in the common case. - Added `Fqueue.singleton` and `Fdeque.singleton`. - Moved `Unix.tm` and `Unix.strftime` from `Core_kernel` to `Core`. Added external time formatting: float (* seconds *)-> string (* format *) -> string = "..." - Made `String_id.Make` call `Pretty_printer.Register`. - Changed `String_id` to allow the pipe character in identifiers. - Made `List.compare` have the usual type from `with compare`, `val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int`. Previously, `List.compare`'s type was: val compare : 'a t -> 'a t -> cmp:('a -> 'a -> int) -> int - Made stable `Map`'s and `Set`'s conform to the `Stable1` interface. - Reworked `Hashtbl.find_exn` to not allocate. Previously, `Hashtbl.find_exn` allocated because it called `Hashtbl.find`, which allocates an option (partially because `Avltree` allocates options in its `find` function). ## 112.24.00 - Added `Time_ns` module. A fragment of `Core.Std.Time_ns` is now in `Core_kernel.Std.Time_ns` such that `Async_kernel` can use `Time_ns` and only depend on `Core_kernel`. - Renamed `Dequeue` as `Deque`. `Dequeue` remains for backward compatibility, but should not be used anymore. Use `Deque` instead. - Added `Fdeque` module, a functional version `Deque`. Deprecate deque-like functions in `Fqueue`. ## 112.17.00 - Added `List.is_prefix`. ```ocaml val List.is_prefix : 'a t -> prefix:'a t -> equal:('a -> 'a -> bool) -> bool ``` - Made `String_id.Make` functor generative, which exposes that the result has `type t = private string`. Previously the result of `String_id.Make` didn't expose `type t = private string` due to a type-checker bug: * http://caml.inria.fr/mantis/view.php?id=6485 * http://caml.inria.fr/mantis/view.php?id=6011 - Used generative functors, e.g. for `Unique_id`. Used generative functors (new feature in 4.02) where previously we used dummy `M : sig end` arguments in the signature and `(struct end)` when applying the functor. Just to note the difference between applicative and generative functors. Suppose we have: ```ocaml module F (M : sig end) : sig type t end ``` and we apply it several times ```ocaml module A = F (struct end) module B = F (struct end) module C = F (String) module D = F (String) ``` Then we have that `A.t <> B.t` but `C.t = D.t`. This can lead to subtle bugs, e.g. `Unique_id.Int (Unit)`. Note that it is perfectly valid to apply any module to `F`, even though that is certainly not what we want. In 4.02, we can explicitly say that functor generates new types, i.e. it is generative. For this we use argument `()`. So `F` becomes ```ocaml module F () : sig type t end ``` You can only apply `F` to `()` or `(struct end)` but each application yields a new type `t`. ```ocaml module A = F () module B = F () module C = F (struct end) module D = F (String) (* illegal *) ``` and now `A.t`, `B.t` and `C.t` are all different. Note that `F (struct end)` is still allowed but was converted to to `F ()` for consistency with signatures. Propagated generativity where necessary. If inside a functor we use generative functor that creates new types, then we also need to make the enclosing functor generative. For functors that don't create types (like `Async.Log.Make_global`), generative or applicative functors are the same, but the syntax of generative functors is lighter. - Exported `Core_kernel.Std.With_return`. - Exposed the record type of `Source_code_position.t`. - In `Weak_hashtbl.create`, exposed the `?growth_allowed` and `?size` arguments of the underlying `Hashtbl.create`. - Added `with compare` to `Array`. - Sped up `Int.pow`. Benchmarks before: | Name | Time/Run | mWd/Run | Percentage | |-----------------------------------------------|--------------|---------|------------| | [int_math.ml:int_math_pow] random[ 5] x 10000 | 140_546.89ns | | 53.98% | | [int_math.ml:int_math_pow] random[10] x 10000 | 173_853.08ns | | 66.77% | | [int_math.ml:int_math_pow] random[30] x 10000 | 219_948.85ns | | 84.47% | | [int_math.ml:int_math_pow] random[60] x 10000 | 260_387.26ns | | 100.00% | | [int_math.ml:int_math_pow] 2 ^ 30 | 11.34ns | | | | [int_math.ml:int_math_pow] 2L ^ 30L | 21.69ns | 3.00w | | | [int_math.ml:int_math_pow] 2L ^ 60L | 22.95ns | 3.00w | | and after: | Name | Time/Run | mWd/Run | Percentage | |-----------------------------------------------|--------------|---------|------------| | [int_math.ml:int_math_pow] random[ 5] x 10000 | 105_200.94ns | | 80.78% | | [int_math.ml:int_math_pow] random[10] x 10000 | 117_365.82ns | | 90.12% | | [int_math.ml:int_math_pow] random[30] x 10000 | 130_234.51ns | | 100.00% | | [int_math.ml:int_math_pow] random[60] x 10000 | 123_621.45ns | | 94.92% | | [int_math.ml:int_math_pow] 2 ^ 30 | 8.55ns | | | | [int_math.ml:int_math_pow] 2L ^ 30L | 22.17ns | 3.00w | 0.02% | | [int_math.ml:int_math_pow] 2L ^ 60L | 22.49ns | 3.00w | 0.02% | - Removed the old, deprecated permission phantom types (`read_only`, etc.) and replaced them with the new =Perms= types. The old types had subtyping based on covariance and `private` types. The new types have subtyping based on contravariance and dropping capabilities. Renamed `read_only` as `read`, since `Perms` doesn't distinguish between them. The idiom for the type of a function that only needs read access changed from: ```ocaml val f : _ t -> ... ``` to ```ocaml val f : [> read ] t -> ... ``` This mostly hit `Iobuf` and its users. - Added `String.is_substring`. - Added `With_return.prepend`, and exposed `With_return.t` as contravariant. ```ocaml (** [prepend a ~f] returns a value [x] such that each call to [x.return] first applies [f] before applying [a.return]. The call to [f] is "prepended" to the call to the original [a.return]. A possible use case is to hand [x] over to an other function which returns ['b] a subtype of ['a], or to capture a common transformation [f] applied to returned values at several call sites. *) val prepend : 'a return -> f:('b -> 'a) -> 'b return ``` - Moved the `Gc` module's alarm functionality into a new `Gc.Expert.Alarm` module. The was done because the Gc alarms introduce threading semantics. - Exposed modules in `Core_kernel.Std`: `Int_conversions`, `Ordered_collection_common` - Removed `Pooled_hashtbl` from `Hashable.S`, to eliminate a dependency cycle between `Int63` and `Pool`. This was needed to use `Int63` in `Pool`. Previously, `Int63 <- Int <- Hashable <- Pool`, which made it impossible to use `Int63` in `Pool`. So, we are removing the dependency `Hashable <- Pool`, simplifying `Hashable` to not include `Pooled_hashtbl`, and letting users call the `Pooled_hashtbl` functor directly when necessary. - Added to `Pool.Pointer.Id` conversions to and from `Int63`. - Made `Pooled_hashtbl.resize` allocate less. - Removed `Pool.pointer_of_id_exn_is_supported`, which was always `true`. - Added `with compare` to `Info`, `Error`, `Or_error`. - Moved `Backtrace` from `Core` - In C stubs, replaced `intxx` types by `intxx_t`. Following this: http://caml.inria.fr/mantis/view.php?id=6517 Fixes #23 - Removed `Backtrace.get_opt`, which is no longer necessary now that `Backtrace.get` is available on all platforms. - Added module types: `Stable`, `Stable1`, `Stable2`. - Exposed `Core_kernel.Std.Avltree`. - Removed from `Binary_packing` a duplicated exception, `Pack_signed_32_argument_out_of_range`. Closes #26 - Made `Info`, `Error`, and `Or_error` stable. The new stable serialization format is distinct from the existing unstable serialization format in the respective modules, which wasn't changed. - Add `Sequence.Step.sexp_of_t`. ## 112.06.00 - Made `String_id` have `Stable_containers.Comparable`. - Changed `Gc.disable_compaction` to require an `allocation_policy`. - Made `Option` match `Invariant.S1`. - Added `Sequence.filter`, `compare`, and `sexp_of_t`. - Added `With_return.with_return_option`, abstracting a common pattern of `with_return`. val with_return : ('a return -> 'a ) -> 'a val with_return_option : ('a return -> unit) -> 'a option - Install a handler for uncaught exceptions, using `Printexc.set_uncaught_exception_handler`, new in OCaml 4.02. - Changed `Day_of_week` representation to a normal variant. - Changed `Exn.handle_uncaught` so that if it is unable to print, it still does `exit 1`. - Added `Sexp.of_sexp_allow_extra_fields`, previously in `Core_extended.Sexp`. - Changed the implementation of `Exn.raise_without_backtrace` to use `raise_notrace`, new in OCaml 4.02. - Added `Float` functions for converting to and from IEEE sign/exponent/mantissa. - Added `String.Caseless` module, which compares and hashes strings ignoring case. - Reimplemented `Type_equal.Id` using extensible types (new in OCaml 4.02), removing a use of `Obj.magic`. Changed `Type_equal.Id.same_witness` to return `option` rather than `Or_error`, which allows it to be implemented without allocation. - Removed a reference to the `Unix` module. Applications using `core_kernel` should be able to link without `unix.cma` again. - Made `Char.is_whitespace` accept `\f` and `\v` as whitespace, matching C. ## 112.01.00 - Removed vestigial code supporting OCaml 4.00. - Used `{Hashable,Comparable}.S_binable` in `Day_of_week` and `Month`. - Improved the performance of `Set_once.set`. - Added `Type_equal.Lift3` functor. - Replaced occurrences of `Obj.magic 0` with `Obj.magic None`. With the former the compiler might think the destination type is always an integer and instruct the GC to ignore references to such values. The latter doesn't have this problem as options are not always integers. - Made `String_id.of_string` faster. - Added `Bigstring` functions for reading and writing the size-prefixed bin-io format. - `bin_prot_size_header_length` - `write_bin_prot` - `read_bin_prot` - `read_bin_prot_verbose_errors` - Added `{Info,Error}.to_string_mach` which produces a single-line sexp from an `Error.t`. - Added `{Info,Error}.createf`, for creation from a format string. - Added new `Perms` module with phantom types for managing access control. This module supersedes the `read_only`, `read_write`, and `immutable` phantom types, which are now deprecated, and will be removed in the future. This module uses a different approach using sets of polymorphic variants as capabilities, and contravariant subtyping to express dropping capabilities. This approach fixes a bug with the current phantom types used for `Ref.Permissioned` in which `immutable` types aren't guaranteed to be immutable: ```ocaml let r = Ref.Permissioned.create 0 let r_immutable = (r : (int, immutable) Ref.Permissioned.t) let () = assert (Ref.Permissioned.get r_immutable = 0) let () = Ref.Permissioned.set r 1 let () = assert (Ref.Permissioned.get r_immutable = 1) ``` The bug stems from the fact that the phantom-type parameter is covariant, which allows OCaml's relaxed value restriction to kick in, which allows one to create a polymorphic value, which can then be viewed as both immutable and read write. Here's a small standalone example to demonstrate: ```ocaml module F (M : sig type +'z t val create : int -> _ t val get : _ t -> int val set : read_write t -> int -> unit end) : sig val t : _ M.t end = struct let t = M.create 0 let t_immutable = (t : immutable M.t) let () = assert (M.get t_immutable = 0); M.set t 1; assert (M.get t_immutable = 1); ;; end ``` The new approach fixes the problem by making the phantom-type parameter contravariant, and using polymorphic variants as capabilities to represent what operations are allowed. Contravariance allows one to drop capabilities, but not add them. - Added `Int.Hex` module, which has hexadecimal sexp/string conversions. - Added `Gc.major_plus_minor_words`, for performance reasons. ## 111.28.00 - Added `Pooled_hashtbl.resize` function, to allow preallocating a table of the desired size, to avoid growth at an undesirable time. - Added `Pooled_hashtbl.on_grow` callback, to get information about hashtbl growth. - Changed `Hashable.Make` to not export a `Hashable` module. The `Hashable` module previously exported was useless, and shadowed `Core.Std.Hashable`. - Moved `Common.does_raise` to `Exn.does_raise`, to make it easier to find. - Added `Float.one`, `minus_one`, and `~-`. (fixes #12). - Removed `Core.Std.unimplemented` and renamed it as `Or_error.unimplemented`. It is not used enough to live in the global namespace. ## 111.25.00 - Fix build on FreeBSD Closes #10 - Added functions to `Container` interface: `sum`, `min_elt`, `max_elt`. ```ocaml (** Returns the sum of [f i] for i in the container *) val sum : (module Commutative_group.S with type t = 'sum) -> t -> f:(elt -> 'sum) -> 'sum (** Returns a min (resp max) element from the collection using the provided [cmp] function. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. Returns [None] iff the collection is empty. *) val min_elt : t -> cmp:(elt -> elt -> int) -> elt option val max_elt : t -> cmp:(elt -> elt -> int) -> elt option ``` - Made `Core_hashtbl_intf` more flexible. For instance supports modules that require typereps to be passed when creating a table. Address the following issues: The type `('a, 'b, 'z) create_options` needs to be consistently used so that `b` corresponds with the type of data values in the returned hash table. The type argument was wrong in several cases. Added the type `('a, 'z) map_options` to `Accessors` so that map-like functions -- those that output hash tables of a different type than they input -- can allow additional arguments. - Fixed a bug in `Dequeue`'s `bin_prot` implementation that caused it to raise when deserializing an empty dequeue. - Made `Container.Make`'s interface match `Monad.Make`. - Deprecated infix `or` in favor of `||`. - Simplified the interface of `Arg` (which was already deprecated in favor of `Command`). - Replaced `Bag.fold_elt` with `Bag.filter`. - `Memo.general` now raises on non-positive `cache_size_bound`. - Removed `Option.apply`. - Removed `Result.call`, `Result.apply`. - Moved `Quichcheck` to `core_extended`. It should not be used in new code. ## 111.21.00 - Removed our custom C stub for closing channels, reverting to the one in the OCaml runtime. A long time ago we found that the OCaml runtime did not release the lock before calling `close` on the fd underlying a channel. On some filesystems (e.g. smb, nfs) this could cause a runtime hang. We filed a bug with INRIA and wrote our own `close` function which `In_channel` calls to this day. The bug has long been fixed, and our function is probably buggy, so this reverts us to the runtime's `close`. - Added `Float.{of,to}_int64_preserve_order`, which implement the order-preserving zero-preserving bijection between non-NaN floats and 99.95% of `Int64`'s. Used the new function to improve `one_ulp`, which is now exposed: (** The next or previous representable float. ULP stands for "unit of least precision", and is the spacing between floating point numbers. Both [one_ulp `Up infinity] and [one_ulp `Down neg_infinity] return a nan. *) val one_ulp : [`Up | `Down] -> t -> t - Changed `Map.symmetric_diff` to return a `Sequence.t` instead of a `list`. - Added `Sequence.filter_map`. - Improved `Stable_unit_test.Make_sexp_deserialization_test`'s error message so that it includes the expected sexp. ## 111.17.00 - In `Bigstring`, made many operations use compiler primitives new in OCaml 4.01. Exposed `Bigstring.get` and `set` as compiler primitives in the interface. Added `Bigstring.unsafe_get_int64_{le,be}_trunc`. - Made `Error` round trip `exn`, i.e. `Error.to_exn (Error.of_exn exn) = exn`. - Added to `failwiths` an optional `?here:Lexing.position` argument. - Added `with typerep` to `Flags.S`. - Optimized `List.dedup []` to return immediately. - Added `data` argument to polymorphic type `Hashtbl_intf.Creators.create_options`. This allows implementations of `Hashtbl_intf.Creators` to have constructor arguments that depend on the type of both key and data values. For example: ```ocaml module type Hashtbl_creators_with_typerep = Hashtbl_intf.Creators with type ('key, 'data, 'z) create_options = typerep_of_key:'key Typerep.t -> typerep_of_data:'data Typerep.t -> 'z ``` - Improved the interface for getting `Monad.Make` to define `map` in terms of `bind`. Instead of passing a `map` function and requiring everyone who wants to define `map` using `bind` to call a special function, we use a variant type to allow the user to say what they want: ```ocaml val map : [ `Define_using_bind | `Custom of ('a t -> f:('a -> 'b) -> 'b t) ] ``` - Improved the performance of many `Dequeue` functions. Previously, many `Dequeue.dequeue`-type functions worked by raising and then catching an exception when the dequeue is empty. This is much slower than just testing for emptiness, which is what the code now does. This improves the performance of `Async.Writer`, which uses `Dequeue.dequeue_front`. ## 111.13.00 - Added a `Sequence` module that implements polymorphic, on-demand sequences. Also implemented conversion to `Sequence.t` from various containers. - Improved the explicitness and expressiveness of `Binary_searchable.binary_search`. `binary_search` now takes an additional (polymorphic variant) argument describing the relationship of the returned position to the element being searched for. val binary_search : ?pos:int -> ?len:int -> t -> compare:(elt -> elt -> int) -> [ `Last_strictly_less_than (** {v | < elt X | v} *) | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) | `Last_equal_to (** {v | = elt X | v} *) | `First_equal_to (** {v | X = elt | v} *) | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) | `First_strictly_greater_than (** {v | X > elt | v} *) ] -> elt -> int option - Added a new function, `Binary_searchable.binary_search_segmented`, that can search an array consisting of two segments, rather than ordered by `compare`. (** [binary_search_segmented ?pos ?len t ~segment_of which] takes an [segment_of] function that divides [t] into two (possibly empty) segments: {v | segment_of elt = `Left | segment_of elt = `Right | v} [binary_search_segmented] returns the index of the element on the boundary of the segments as specified by [which]: [`Last_on_left] yields the index of the last element of the left segment, while [`First_on_right] yields the index of the first element of the right segment. It returns [None] if the segment is empty. By default, [binary_search] searches the entire [t]. One can supply [?pos] or [?len] to search a slice of [t]. [binary_search_segmented] does not check that [segment_of] segments [t] as in the diagram, and behavior is unspecified if [segment_of] doesn't segment [t]. Behavior is also unspecified if [segment_of] mutates [t]. *) val binary_search_segmented : ?pos:int -> ?len:int -> t -> segment_of:(elt -> [ `Left | `Right ]) -> [ `Last_on_left | `First_on_right ] -> int option - Made `Queue` match `Binary_searchable.S1`. - Made `Gc.Stat` and `Gc.Control` match `Comparable`. - Fixed some unit tests in `Type_immediacy` that were fragile due to GC. ## 111.11.00 - Added to `String` functions for substring search and replace, based on the KMP algorithm. Here are some benchmarks, comparing `Re2` for a fixed pattern, Mark's kmp from extended_string, and this implementation ("needle"). The pattern is the usual `abacabadabacabae...`. The text looks similar, with the pattern occurring at the very end. For =Re2= and =Needle= search benchmarks, the pattern is preprocessed in advance, outside of the benchmark. FWIW: I've also tried searches with pattern size = 32767, but =Re2= blows up, saying: ``` re2/dfa.cc:447: DFA out of memory: prog size 32771 mem 2664898 ``` | Name | Time/Run | mWd/Run | mjWd/Run | Prom/Run | Percentage | |-------------------------------|-----------------|---------------|-------------|----------|------------| | create_needle_15 | 102.56ns | 21.00w | | | | | re2_compile_15 | 6_261.48ns | | 3.00w | | 0.01% | | create_needle_1023 | 13_870.48ns | 5.00w | 1_024.01w | | 0.03% | | re2_compile_1023 | 107_533.32ns | | 3.03w | | 0.24% | | create_needle_8191 | 90_107.02ns | 5.00w | 8_192.01w | | 0.20% | | re2_compile_8191 | 1_059_873.47ns | | 3.28w | 0.28w | 2.37% | | create_needle_524287 | 6_430_623.96ns | 5.00w | 524_288.09w | | 14.35% | | re2_compile_524287 | 44_799_605.83ns | | 3.77w | 0.77w | 100.00% | | needle_search_15_95 | 349.65ns | 4.00w | | | | | re2_search_15_95 | 483.11ns | | | | | | mshinwell_search_15_95 | 1_151.38ns | 781.01w | | | | | needle_search_15_815 | 2_838.85ns | 4.00w | | | | | re2_search_15_815 | 3_293.06ns | | | | | | mshinwell_search_15_815 | 8_360.57ns | 5_821.07w | 0.55w | 0.55w | 0.02% | | needle_search_15_2415 | 8_395.84ns | 4.00w | | | 0.02% | | re2_search_15_2415 | 9_594.14ns | | | | 0.02% | | mshinwell_search_15_2415 | 24_602.09ns | 17_021.16w | 1.62w | 1.62w | 0.05% | | needle_search_1023_6143 | 14_825.50ns | 4.00w | | | 0.03% | | re2_search_1023_6143 | 40_926.59ns | | | | 0.09% | | mshinwell_search_1023_6143 | 81_930.46ns | 49_149.66w | 1_025.65w | 1.65w | 0.18% | | needle_search_1023_52223 | 126_465.96ns | 4.00w | | | 0.28% | | re2_search_1023_52223 | 365_359.98ns | | | | 0.82% | | mshinwell_search_1023_52223 | 527_323.73ns | 371_715.39w | 1_033.17w | 9.17w | 1.18% | | needle_search_1023_154623 | 377_539.53ns | 4.00w | | | 0.84% | | re2_search_1023_154623 | 1_001_251.93ns | | | | 2.23% | | mshinwell_search_1023_154623 | 1_499_835.01ns | 1_088_518.15w | 1_033.19w | 9.19w | 3.35% | | needle_search_8191_49151 | 115_223.31ns | 4.00w | | | 0.26% | | re2_search_8191_49151 | 559_487.38ns | | | | 1.25% | | mshinwell_search_8191_49151 | 653_981.19ns | 393_219.50w | 8_201.01w | 9.01w | 1.46% | | needle_search_8191_417791 | 976_725.24ns | 4.00w | | | 2.18% | | re2_search_8191_417791 | 4_713_965.69ns | | | | 10.52% | | mshinwell_search_8191_417791 | 4_224_417.93ns | 2_973_709.32w | 8_202.37w | 10.37w | 9.43% | | needle_search_8191_1236991 | 2_912_863.78ns | 4.00w | | | 6.50% | | re2_search_8191_1236991 | 14_039_230.59ns | | | | 31.34% | | mshinwell_search_8191_1236991 | 11_997_713.73ns | 8_708_130.87w | 8_202.47w | 10.47w | 26.78% | - Added to `Set` functions for converting to and from a `Map.t`. ```ocaml val to_map : ('key, 'cmp) t -> f:('key -> 'data) -> ('key, 'data, 'cmp) Map.t val of_map_keys : ('key, _, 'cmp) Map.t -> ('key, 'cmp) t ``` This required adding some additional type trickery to `Core_set_intf` to indicate that the comparator for a given module may or may not be fixed. - Added an optional `iter` parameter to `Container.Make`. A direct implementation of `iter` is often more efficient than defining `iter` in terms of `fold`, and in these cases, the results of `Container.Make` that are defined in terms of `iter` will be more efficient also. - Added `Int.pow` (and for other integer types), for bounds-checked integer exponentiation. ## 111.08.00 - Added `Hashtbl.for_all` and `for_alli`. - Added `Float.to_padded_compact_string` for converting a floating point number to a lossy, compact, human-readable representation. E.g., `1_000_001.00` becomes `"1m "`. - Tweaked the form of the definition of `Blang.Stable.V1`. Removed a `type t_` that is not necessary now that we can use `nonrec` without triggering spurious warnings. ## 111.06.00 - Added inline benchmarks for `Array` Here are some of the results from the new benchmarks, with some indexed tests dropped. | Name | Time/Run | mWd/Run | mjWd/Run | |-----------------------------------------------------|-------------|---------|-----------| | [core_array.ml:Alloc] create:0 | 13.65ns | | | | [core_array.ml:Alloc] create:100 | 99.83ns | 101.00w | | | [core_array.ml:Alloc] create:255 | 201.32ns | 256.00w | | | [core_array.ml:Alloc] create:256 | 1_432.43ns | | 257.00w | | [core_array.ml:Alloc] create:1000 | 5_605.58ns | | 1_001.01w | | [core_array.ml:Blit.Poly] blit (tuple):10 | 87.10ns | | | | [core_array.ml:Blit.Poly] blito (tuple):10 | 112.14ns | 2.00w | | | [core_array.ml:Blit.Poly] blit (int):10 | 85.25ns | | | | [core_array.ml:Blit.Poly] blito (int):10 | 107.23ns | 2.00w | | | [core_array.ml:Blit.Poly] blit (float):10 | 84.71ns | | | | [core_array.ml:Blit.Poly] blito (float):10 | 86.71ns | 2.00w | | | [core_array.ml:Blit.Int] blit:10 | 19.77ns | | | | [core_array.ml:Blit.Int] blito:10 | 23.54ns | 2.00w | | | [core_array.ml:Blit.Float] blit:10 | 19.87ns | | | | [core_array.ml:Blit.Float] blito:10 | 24.12ns | 2.00w | | | [core_array.ml:Is empty] Polymorphic '=' | 18.21ns | | | | [core_array.ml:Is empty] Array.equal | 8.08ns | 6.00w | | | [core_array.ml:Is empty] phys_equal | 2.98ns | | | | [core_array.ml:Is empty] Array.is_empty (empty) | 2.98ns | | | | [core_array.ml:Is empty] Array.is_empty (non-empty) | 3.00ns | | | - Moved `Thread_safe_queue` to core - Generalized the type of `Exn.handle_uncaught_and_exit` to `(unit -> 'a) -> 'a`. In the case where `handle_uncaught_and_exit` succeeds, it can return the value of the supplied function. It's type had been: ```ocaml val handle_uncaught_and_exit : (unit -> never_returns) -> never_returns ``` - Added `Int.round*` functions for rounding to a multiple of another int. ```ocaml val round : ?dir:[ `Zero | `Nearest | `Up | `Down ] -> t -> to_multiple_of:t -> t val round_towards_zero : t -> to_multiple_of:t -> t val round_down : t -> to_multiple_of:t -> t val round_up : t -> to_multiple_of:t -> t val round_nearest : t -> to_multiple_of:t -> t ``` These functions were added to `Int_intf.S`, implemented by `Int`, `Nativeint`, `Int32`, and `Int64`. Various int modules were also lightly refactored to make it easier in the future to implement common operators available for all modules implementing the int interface via a functor to share the code. ## 111.03.00 - Added `Error.to_string_hum_deprecated` that is the same as `Error.to_string_hum` pre 109.61. - Changed `Error.to_string_hum` so that `Error.to_string_hum (Error.of_string s) = s`. This fixed undesirable sexp escaping introduced in 109.61 and restores the pre-109.61 behavior for the special case of `Error.of_string`. A consequence of the removal of the custom `to_string_hum` converter in 109.61 was that: ```ocaml Error.to_string_hum (Error.of_string s) = Sexp.to_string_hum (Sexp.Atom s) ``` That introduced sexp escaping of `s`. - Added to `Doubly_linked` functions for moving an element within a list. ```ocaml val move_to_front : 'a t -> 'a Elt.t -> unit val move_to_back : 'a t -> 'a Elt.t -> unit val move_after : 'a t -> 'a Elt.t -> anchor:'a Elt.t -> unit val move_before : 'a t -> 'a Elt.t -> anchor:'a Elt.t -> unit ``` - Improved `Core_map_unit_tests.Unit_tests` to allow arbitrary data in the map, not just `ints`. This was done by eta expansion. ## 110.01.00 - Changed `Queue` from a linked to an array-backed implementation. Renamed the previous implementation to `Linked_queue`. Renamed `transfer`, which was constant time, as `blit_transfer`, which is linear time. Removed `partial_iter`. One can use `with_return`. Added `singleton`, `filter`, `get`, `set`. - For `Error` and `Info`, changed `to_string_hum` to use `sexp_of_t` and `Sexp.to_string_hum`, rather than a custom string format. - Changed the output format of `Validate.errors` to be a sexp. - Added `Hashtbl.of_alist_or_error` and `Map.of_alist_or_error`. - Added `String_id.Make` functor, which includes a module name for better error messages. - Exposed `Bucket.size`. - Changed the default for `Debug.should_print_backtrace` to be `false` rather than `true`. Usually the backtraces are noise. - Removed the tuning of gc parameters built in to Core, so that the default is now the stock OCaml settings. Such tuning doesn't belong in Core, but rather done per application. Also, the Core settings had fallen way out of date, and not kept up with changes in the OCaml runtime settings. We have one example (lwt on async) where the Core settings significantly slowed down a program. - Added `Exn.raise_without_backtrace`, to raise without building a backtrace. `raise_without_backtrace` never builds a backtrace, even when `Backtrace.am_recording ()`. - Made `with_return` faster by using `Exn.raise_without_backtrace`. - Improved `with_return` to detect usage of a `return` after its creating `with_return` has returned. ## 109.60.00 - Added `Gc.keep_alive`, which ensures its argument is live at the point of the call. - Added `Sexp.With_text` module, which keeps a value and the a sexp it was generated from, preserving the original formatting. ## 109.58.00 - Moved all of the `Gc` module into `Core_kernel`. Part of the `Gc` module used to be in `Core` because it used threads. But it doesn't use threads anymore, so can be all in `Core_kernel`. - Made `Stable.Map` and `Set` have `with compare`. - Added `String.rev`. Closes janestreet/core#16 We will not add `String.rev_inplace`, as we do not want to encourage mutation of strings. - Made `Univ_map.Key` equivalent to `Type_equal.Id`. - Added `Univ.view`, which exposes `Univ.t` as an existential, `type t = T : 'a Id.t * 'a -> t`. Exposing the existential makes it possible to, for example, use `Univ_map.set` to construct a `Univ_map.t`from a list of `Univ.t`s. This representation is currently the same as the underlying representation, but to make changes to the underlying representation easier, it has been put in a module `Univ.View`. ## 109.55.00 - Added `with typerep` to many `Core` types. - Changed `Flat_queue` to raise if the queue is mutated during iteration. - Improved `Map.merge` to run in linear time. ## 109.53.00 - Added `Float.to_string_round_trippable`, which produces a string that loses no precision but (usually) uses as few digits as possible. This can eliminate noise at the end (e.g. `3.14` not `3.1400000000000001243`). Benchmarks: New sexp: | Name | Time/Run | mWd/Run | Percentage | |------------------------|----------|---------|------------| | new Float.sexp_of 3.14 | 463.28ns | 6.00w | 48.88% | | new Float.sexp_of e | 947.71ns | 12.00w | 100.00% | Old sexp: | Name | Time/Run | mWd/Run | Percentage | |------------------------|----------|---------|------------| | old Float.sexp_of 3.14 | 841.99ns | 178.00w | 98.03% | | old Float.sexp_of e | 858.94ns | 178.00w | 100.00% | Much of the speedup in the 3.14 case comes from the fact that `format_float "%.15g"` is much faster than `sprintf "%.15g"`. And of course the above does not capture any of the benefits of dealing with shorter strings down the road. Here are some detailed benchmarks of the various bits and pieces of what's going on here: | Name | Time/Run | mWd/Run | Percentage | |-------------------------------------|------------|---------|------------| | format_float '%.15g' 3.14 | 335.96ns | 2.00w | 32.71% | | format_float '%.17g' 3.14 | 394.18ns | 4.00w | 38.38% | | format_float '%.20g' 3.14 | 459.79ns | 4.00w | 44.77% | | format_float '%.40g' 3.14 | 638.06ns | 7.00w | 62.13% | | sprintf '%.15g' 3.14 | 723.71ns | 165.00w | 70.47% | | sprintf '%.17g' 3.14 | 803.44ns | 173.00w | 78.23% | | sprintf '%.20g' 3.14 | 920.78ns | 176.00w | 89.66% | | sprintf '%.40g' 3.14 | 990.09ns | 187.00w | 96.41% | | format_float '%.15g' e | 357.59ns | 4.00w | 34.82% | | format_float '%.17g' e | 372.16ns | 4.00w | 36.24% | | format_float '%.20g' e | 434.59ns | 4.00w | 42.32% | | format_float '%.40g' e | 592.78ns | 7.00w | 57.72% | | sprintf '%.15g' e | 742.12ns | 173.00w | 72.26% | | sprintf '%.17g' e | 747.92ns | 173.00w | 72.83% | | sprintf '%.20g' e | 836.30ns | 176.00w | 81.43% | | sprintf '%.40g' e | 1_026.96ns | 187.00w | 100.00% | | valid_float_lexem 12345678901234567 | 76.29ns | 9.00w | 7.43% | | valid_float_lexem 3.14 | 9.28ns | 5.00w | 0.90% | | float_of_string 3.14 | 130.19ns | 2.00w | 12.68% | | float_of_string 1234567890123456.7 | 184.33ns | 2.00w | 17.95% | | to_string 3.14 | 316.47ns | 7.00w | 30.82% | | to_string_round_trippable 3.14 | 466.02ns | 9.00w | 45.38% | | to_string e | 315.41ns | 7.00w | 30.71% | | to_string_round_trippable e | 949.12ns | 15.00w | 92.42% | - Replaced `Float.min_positive_value` with `min_positive_normal_value` and `min_positive_subnormal_value`. - Added some functions to `Float.O`: `abs`, `of_float`, and `Robustly_comparable.S`. - Small improvements to the `Heap` module. Implemented `Heap.iter` directly rather than in terms of `fold`. In `heap.ml`, fixed the idiom for using `Container.Make`. - Added an `Int.O` and other `Int*.O` modules, with arithmetic operators, infix comparators, and a few useful arithmetic values. - Added `Int.( ~- )`, for unary negation. - Added `Pool.unsafe_free`. - Added `Percent` module. ## 109.52.00 - Added to `Binary_packing` module functions for packing and unpacking signed 64-bit ints in little- and big-endian. - Changed the `Comparator` interfaces to no longer have `with bin_io` or `with sexp`. The `Comparator` interfaces are now just about having a comparator. Also, renamed `type comparator` as `type comparator_witness`. And, removed `Comparator.S_binable`, since one can use: ```ocaml type t with bin_io include Comparator.S with type t :` t ``` - Changed `Comparator.Make` to return a module without a type `t`, like other `*able` functors, This made it possible to remove the signature constraint when `Comparator.Make` is applied. - Made `Comparable.S_binable` be like `Comparable.S` and not have `type t with sexp`. The following two functors now fail to type check: ```ocaml module F1 (M : Comparable.S ) : sig type t with sexp end ` M module F2 (M : Comparable.S_binable) : sig type t with sexp end ` M ``` whereas previously `F1` was rejected and `F2` was accepted. - Changed the `Monad.Make` functor to require a `val map` argument. This was done since we almost always want a specialized `map`, and we kept making the mistake of not overriding the generic one in the three places needed. Added `Monad.map_via_bind`, which one can use to create a standard `map` function using `bind` and `return`. - Removed unnecessary signature constraints on the result of applying `Monad.Make`. Some time ago, `Monad.Make` changed from returning: ```ocaml S with type 'a t ` 'a M.t ``` to returning: ```ocaml S with type 'a t :` 'a M.t ``` so we no longer need to constrain the result of `Monad.Make` at its uses to remove `t`. - Changed `String.exists` and `String.for_all` to iterate by increasing index rather than decreasing. - Added `with compare` to module `Ref`. - Made `Flags` be `Comparable`, with the order consistent with bitwise subset. - Cleaned up the implementation of `Union_find`. Improvemed the code in `union_find.ml`: * Removed an assert false. * do not reallocate a parent node during compress. This should result in more stability for sets memory wise. * Added implementation notes. * Renamed internal variant constructors. * Added unit tests. - Added `Float.O`, a sub-module intended to be used with local opens. The idea is to be able to write expressions like: ```ocaml Float.O.((3. + 4.) > 6. / 2.) ``` This idiom is expected to be extended to other modules as well. - Added a `sexp_of_t` converter to `Type_equal.Id`. - Replaced `Univ.Constr` with `Type_equal.Id`. - Added `Debug.eprintf`, analogous to `eprint` and `eprints`. ## 109.47.00 - Added `Error.to_info` and `of_info`. - Significantly sped up `Float.iround_*` functions. For `iround_down_exn`, the new version appears to use about 25% of the CPU time of the old version on non-negative floats. For negative floats it uses around 60% of the CPU time. | Name | Time (ns) | % of max | |-------------------------|-----------|----------| | old iround_down_exn pos | 15.02 | 95.23 | | new iround_down_exn pos | 3.75 | 23.75 | | old iround_down_exn neg | 15.78 | 100.00 | | new iround_down_exn neg | 9.80 | 62.10 | - Added `Binary_searchable.Make` functor to core, and used it in `Array` and `Dequeue`. - Fixed `Bounded_int_table` to match `Invariant.S2`. - Added to `Pool` support for `10-`, `11-`, and `12-` tuples. - Added functions to the `Gc` module to get usage information without allocating. Added these functions, all of type `unit -> int`: ``` minor_collections major_collections heap_words heap_chunks compactions top_heap_words ``` They all satisfy: ```ocaml Gc.f () = (Gc.quick_stat ()).Gc.Stat.f ``` They all avoid the allocation of the stat record, so one can monitor the garbage collector without perturbing it. ## 109.45.00 - Changed `Blang.bind` to short-circuit `And`, `Or`, and `If` expressions. For example if `bind t1 f ` false`, then `bind (and_ t1 t2) ` false`, and will not evaluate `bind t2 f`. - Renamed `Dequeue.get` as `get_opt`, and `get_exn` as `get`, to be consistent with other containers which don't use the `_exn` suffix for subscripting exceptions. - Removed `Source_code_position.to_sexp_hum`, in favor of `sexp_of_t_hum`, which works smoothly with `with sexp`. - Changed `Flat_queue_unit_tests` to run `Flat_queue.invariant`, which was mistakenly not being used. ## 109.44.00 - Implemented `Dequeue.iter` directly, instead of as a specialization of `fold`. Extended random tests to cover `iter`. ## 109.42.00 - Added `Array.is_sorted_strictly` and `List.is_sorted_strictly`. ```ocaml val is_sorted_strictly : 'a t -> cmp:('a -> 'a -> int) -> bool ``` - Added `Array.find_consecutive_duplicate` and `List.find_consecutive_duplicate`. ```ocaml val find_consecutive_duplicate : 'a t -> equal:('a -> 'a -> bool) -> ('a * 'a) option ``` - Added `Array.truncate`, which changes (shortens) the length of an array. ```ocaml val truncate : _ t -> len:int -> unit ``` - Improved the debugging message in `Bounded_int_table.remove` to show the data structure's details. - Added `Float.iround_lbound` and `iround_ubound`, the bounds for rounding to `int`. - Added `Hashtbl.similar`, which is like `equal`, but allows the types of the values in the two tables to differ. - Added `Pool.Pointer.phys_compare`, which is analagous to `phys_equal`, and does not require an argument comparison function. ```ocaml val phys_compare : 'a t -> 'a t -> int ``` - Exposed that `Pool.Debug`'s output types are the same as its input types. ## 109.41.00 - Added `Map.of_alist_reduce`. This function is a natural addition alongside `of_alist_fold`. Its advantage is that it does not require an `init` argument like `of_alist_fold`. Moreover, it does not involve `option` types, like `List.reduce` does in order to handle the empty list case. ## 109.39.00 - Implemented `Heap.iter` directly instead of in terms of `fold`. ## 109.37.00 - Added Core.Std.Poly as a short name for Core.Std.Polymorphic_compare. - Exposed module Core.Std.Decimal. ## 109.36.00 - Made `Hashtbl.Poly.hash` equal `Caml.Hashtbl.hash`, and changed changed `String.hash` and `Float.hash` to match OCaml's hash function. Previously, `Core.Poly.hash` had been defined as: ```ocaml let hash x = hash_param 10 100 x ``` This fell out of sync with OCaml's hash function, and was providing worse hash values. - Fixed `Obj_array.singleton` to never create a float array. Also made it clearer that `Obj_array.copy` could never create a float array. - Changed `Pool.create` to allow zero-length pools. Previously, `Pool.create ~capacity:0` had raised, which made it easy to write code that blows up on edge cases for no apparent reason. For example, `Heap.copy` was written in a way that copying an empty heap would blow up (regardless of its capacity), and `Heap.of_array` would also blow up on an empty array. - Added `String.split_lines`. ```ocaml (** [split_lines t] returns the list of lines that comprise [t]. The lines do not include the trailing ["\n"] or ["\r\n"]. *) val split_lines : t -> t list ``` ## 109.35.00 - Added `with compare` to `List.Assoc.t`. - Made `Pooled_hashtbl.create` handle non-positive and very large `size`s in the same way as `Core.Hashtbl`. - Added `is_error`, `is_ok`, and `does_raise` to `Core.Std`. ```ocaml let is_error ` Result.is_error let is_ok ` Result.is_ok val does_raise : (unit -> _) -> bool ``` - Reimplemented `Heap` and reworked the interface to be more standard. The new implementation uses pairing heaps and `Pool`. - Added a module `Pool.Unsafe`, which is like `Pool`, except that `create` doesn't require an initial value. This makes it unsafe to access pool pointers after they have been freed. But it is useful for situations when one isn't able to create an initial value, e.g. `Core.Heap`. - Removed `Time.to_localized_string` and `Time.to_string_deprecated`. These did not include the time-zone offset. Instead, use `Time.to_string` and `Time.to_string_abs`, which do include the time-zone offset. - Exposed that `Int63.t = private int` on 64-bit machines. This lets the OCaml compiler avoid `caml_modify` when dealing with it. - Added `Gc` stat functions that don't allocate: `Gc.minor_words`, `Gc.major_words`, `Gc.promoted_words`. Added the following `Gc` functions: ```ocaml Gc.minor_words : unit -> int Gc.major_words : unit -> int Gc.promoted_words : unit -> int ``` such that these functions cause no allocations by themselves. The assumption being that 63-bit ints should be large enough to express total allocations for most programs. On 32-bit machines the numbers may overflow and these functions are not as generally useful. These functions were added because doing memory allocation debugging with `Gc.quick_stat` as the primary means of understanding allocations is difficult: tracking down allocations of the order of a few hundred words in a hot loop by putting in lots of `quick_stat` statements becomes too intrusive because of the memory allocations they cause. Here are some benchmarks of existing `Gc` functions and the newly added functions: ``` $ ./test_bench.exe -q 2 -clear name time +alloc +time-err Estimated testing time 12s (change using -quota SECS). ``` | Name | Time (ns) | 95% ci | Time R^2 | Minor | |-----------------|-----------|-------------|----------|-------| | quick_stat | 92.16 | +0.72 -0.64 | 1.00 | 23.00 | | counters | 33.63 | +0.26 -0.23 | 1.00 | 10.00 | | allocated_bytes | 37.89 | +0.34 -0.32 | 1.00 | 12.00 | | minor_words | 4.63 | +0.03 -0.02 | 1.00 | | | major_words | 4.36 | +0.02 -0.02 | 1.00 | | | promoted_words | 4.10 | +0.03 -0.02 | 1.00 | | ## 109.34.00 - Added a new module, `Flat_queue`, which is a queue of flat tuples. This is essentially: ```ocaml ('a1 * .. * 'aN) Queue.t ``` However the queue is implemented as a `Flat_array`, so the tuples are layed out flat in the array and not allocated. - Improved `Bounded_int_table.remove`'s error message when it detects an internal inconsistency. - Added new `Debug` module. - Changed `Invariant.invariant` to take `_here_` rather than a string. - Made `Float` satisfy the `Identifiable` interface. ## 109.32.00 - Added `val Option.merge: 'a t -> 'a t -> f:('a -> 'a -> 'a) -> 'a t`. - Added `val Validate.failf : ('a, unit, string, t) format4 -> 'a`. - In `Validated.Make_binable`, made it possible to apply the validation function when un-bin-io-ing a value. - Added `module Pooled_hashtbl` to `module type Hashable`. This is an alternative implementation to `Core.Hashtbl`. It uses a standard linked list to resolve hash collisions, and `Pool` to manage the linked-list nodes. ## 109.31.00 - Renamed some functions in module `Lazy`: dropped the `lazy_` prefix from `is_val`, `from_val`, and `from_fun`. ## 109.30.00 - Added module, `Core.Blit`, which codifies the type, implementation, and unit-testing of blit functions. - Added `remove_zero_flags` option to `Flags.Make`, to support flags that are zero. This fixes a problem with `Flags.Make` on CentOS 5 because `O_CLOEXEC` is `0` there. - Removed `Pool.None`, and folded `Pool.Obj_array` into `Pool` proper. `Pool.None` had its day, but `Pool.Obj_array` dominates it, so we don't need it any more. ## 109.28.00 - Moved all the contents of the `Zero` library into `Core`, mostly into `Core_kernel`. We want to start using `Zero` stuff more in `Core`, which couldn't be done with `Zero` as a separate library. Everything moved into `Core_kernel`, except for `Timing_wheel`, which moved into `Core` proper, due to its dependence on `Time`. - Renamed `Flat_tuple_array` as `Flat_array`. - Added `Dequeue.{front,back}_index_exn` These are more efficient than using `{front,back}_index` and then `Option.value_exn`. - Exposed `Core.String.unsafe_{get,set}`. core_kernel-113.00.00/COPYRIGHT.txt000066400000000000000000000005101256461164500164230ustar00rootroot00000000000000Copyright (C) 2008- Jane Street Group, LLC 1 New York Plaza, 33rd Floor New York, NY 10004 USA email: opensource@janestreet.com The contents of some files in this distribution was derived from external sources with compatible licenses. The original copyright and license notice was preserved in the affected files. core_kernel-113.00.00/INRIA-DISCLAIMER.txt000066400000000000000000000013321256461164500173320ustar00rootroot00000000000000THIS SOFTWARE IS PROVIDED BY INRIA AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL INRIA OR ITS CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. core_kernel-113.00.00/INSTALL.txt000066400000000000000000000026001256461164500161630ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 4f944115f7f83b3bc7043837bd2d9cbe) *) This is the INSTALL file for the core_kernel distribution. This package uses OASIS to generate its build system. See section OASIS for full information. Dependencies ============ In order to compile this package, you will need: * ocaml (>= 4.00.1) for all, test test_pool_caml_modify_check * findlib (>= 1.3.2) * bin_prot for library core_kernel * comparelib for library core_kernel * custom_printf for library core_kernel * enumerate for library core_kernel * fieldslib for library core_kernel * herelib for library core_kernel * pa_bench for library core_kernel * pa_test for library core_kernel * pa_ounit for library check_caml_modify, library core_kernel * pa_pipebang for library core_kernel * sexplib for library core_kernel * typerep_lib for library core_kernel * variantslib for library core_kernel Installing ========== 1. Uncompress the source archive and go to the root of the package 2. Run 'ocaml setup.ml -configure' 3. Run 'ocaml setup.ml -build' 4. Run 'ocaml setup.ml -install' Uninstalling ============ 1. Go to the root of the package 2. Run 'ocaml setup.ml -uninstall' OASIS ===== OASIS is a program that generates a setup.ml file using a simple '_oasis' configuration file. The generated setup only depends on the standard OCaml installation: no additional library is required. (* OASIS_STOP *) core_kernel-113.00.00/LICENSE.txt000066400000000000000000000261361256461164500161510ustar00rootroot00000000000000 Apache License Version 2.0, January 2004 http://www.apache.org/licenses/ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION 1. Definitions. "License" shall mean the terms and conditions for use, reproduction, and distribution as defined by Sections 1 through 9 of this document. "Licensor" shall mean the copyright owner or entity authorized by the copyright owner that is granting the License. "Legal Entity" shall mean the union of the acting entity and all other entities that control, are controlled by, or are under common control with that entity. For the purposes of this definition, "control" means (i) the power, direct or indirect, to cause the direction or management of such entity, whether by contract or otherwise, or (ii) ownership of fifty percent (50%) or more of the outstanding shares, or (iii) beneficial ownership of such entity. "You" (or "Your") shall mean an individual or Legal Entity exercising permissions granted by this License. "Source" form shall mean the preferred form for making modifications, including but not limited to software source code, documentation source, and configuration files. "Object" form shall mean any form resulting from mechanical transformation or translation of a Source form, including but not limited to compiled object code, generated documentation, and conversions to other media types. "Work" shall mean the work of authorship, whether in Source or Object form, made available under the License, as indicated by a copyright notice that is included in or attached to the work (an example is provided in the Appendix below). "Derivative Works" shall mean any work, whether in Source or Object form, that is based on (or derived from) the Work and for which the editorial revisions, annotations, elaborations, or other modifications represent, as a whole, an original work of authorship. For the purposes of this License, Derivative Works shall not include works that remain separable from, or merely link (or bind by name) to the interfaces of, the Work and Derivative Works thereof. "Contribution" shall mean any work of authorship, including the original version of the Work and any modifications or additions to that Work or Derivative Works thereof, that is intentionally submitted to Licensor for inclusion in the Work by the copyright owner or by an individual or Legal Entity authorized to submit on behalf of the copyright owner. For the purposes of this definition, "submitted" means any form of electronic, verbal, or written communication sent to the Licensor or its representatives, including but not limited to communication on electronic mailing lists, source code control systems, and issue tracking systems that are managed by, or on behalf of, the Licensor for the purpose of discussing and improving the Work, but excluding communication that is conspicuously marked or otherwise designated in writing by the copyright owner as "Not a Contribution." "Contributor" shall mean Licensor and any individual or Legal Entity on behalf of whom a Contribution has been received by Licensor and subsequently incorporated within the Work. 2. Grant of Copyright License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable copyright license to reproduce, prepare Derivative Works of, publicly display, publicly perform, sublicense, and distribute the Work and such Derivative Works in Source or Object form. 3. Grant of Patent License. Subject to the terms and conditions of this License, each Contributor hereby grants to You a perpetual, worldwide, non-exclusive, no-charge, royalty-free, irrevocable (except as stated in this section) patent license to make, have made, use, offer to sell, sell, import, and otherwise transfer the Work, where such license applies only to those patent claims licensable by such Contributor that are necessarily infringed by their Contribution(s) alone or by combination of their Contribution(s) with the Work to which such Contribution(s) was submitted. If You institute patent litigation against any entity (including a cross-claim or counterclaim in a lawsuit) alleging that the Work or a Contribution incorporated within the Work constitutes direct or contributory patent infringement, then any patent licenses granted to You under this License for that Work shall terminate as of the date such litigation is filed. 4. Redistribution. You may reproduce and distribute copies of the Work or Derivative Works thereof in any medium, with or without modifications, and in Source or Object form, provided that You meet the following conditions: (a) You must give any other recipients of the Work or Derivative Works a copy of this License; and (b) You must cause any modified files to carry prominent notices stating that You changed the files; and (c) You must retain, in the Source form of any Derivative Works that You distribute, all copyright, patent, trademark, and attribution notices from the Source form of the Work, excluding those notices that do not pertain to any part of the Derivative Works; and (d) If the Work includes a "NOTICE" text file as part of its distribution, then any Derivative Works that You distribute must include a readable copy of the attribution notices contained within such NOTICE file, excluding those notices that do not pertain to any part of the Derivative Works, in at least one of the following places: within a NOTICE text file distributed as part of the Derivative Works; within the Source form or documentation, if provided along with the Derivative Works; or, within a display generated by the Derivative Works, if and wherever such third-party notices normally appear. The contents of the NOTICE file are for informational purposes only and do not modify the License. You may add Your own attribution notices within Derivative Works that You distribute, alongside or as an addendum to the NOTICE text from the Work, provided that such additional attribution notices cannot be construed as modifying the License. You may add Your own copyright statement to Your modifications and may provide additional or different license terms and conditions for use, reproduction, or distribution of Your modifications, or for any such Derivative Works as a whole, provided Your use, reproduction, and distribution of the Work otherwise complies with the conditions stated in this License. 5. Submission of Contributions. Unless You explicitly state otherwise, any Contribution intentionally submitted for inclusion in the Work by You to the Licensor shall be under the terms and conditions of this License, without any additional terms or conditions. Notwithstanding the above, nothing herein shall supersede or modify the terms of any separate license agreement you may have executed with Licensor regarding such Contributions. 6. Trademarks. This License does not grant permission to use the trade names, trademarks, service marks, or product names of the Licensor, except as required for reasonable and customary use in describing the origin of the Work and reproducing the content of the NOTICE file. 7. Disclaimer of Warranty. Unless required by applicable law or agreed to in writing, Licensor provides the Work (and each Contributor provides its Contributions) on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied, including, without limitation, any warranties or conditions of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A PARTICULAR PURPOSE. You are solely responsible for determining the appropriateness of using or redistributing the Work and assume any risks associated with Your exercise of permissions under this License. 8. Limitation of Liability. In no event and under no legal theory, whether in tort (including negligence), contract, or otherwise, unless required by applicable law (such as deliberate and grossly negligent acts) or agreed to in writing, shall any Contributor be liable to You for damages, including any direct, indirect, special, incidental, or consequential damages of any character arising as a result of this License or out of the use or inability to use the Work (including but not limited to damages for loss of goodwill, work stoppage, computer failure or malfunction, or any and all other commercial damages or losses), even if such Contributor has been advised of the possibility of such damages. 9. Accepting Warranty or Additional Liability. While redistributing the Work or Derivative Works thereof, You may choose to offer, and charge a fee for, acceptance of support, warranty, indemnity, or other liability obligations and/or rights consistent with this License. However, in accepting such obligations, You may act only on Your own behalf and on Your sole responsibility, not on behalf of any other Contributor, and only if You agree to indemnify, defend, and hold each Contributor harmless for any liability incurred by, or claims asserted against, such Contributor by reason of your accepting any such warranty or additional liability. END OF TERMS AND CONDITIONS APPENDIX: How to apply the Apache License to your work. To apply the Apache License to your work, attach the following boilerplate notice, with the fields enclosed by brackets "[]" replaced with your own identifying information. (Don't include the brackets!) The text should be enclosed in the appropriate comment syntax for the file format. We also recommend that a file or class name and description of purpose be included on the same "printed page" as the copyright notice for easier identification within third-party archives. Copyright [yyyy] [name of copyright owner] Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.apache.org/licenses/LICENSE-2.0 Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. core_kernel-113.00.00/MLton-license.txt000066400000000000000000000025041256461164500175310ustar00rootroot00000000000000This is the license for MLton, a whole-program optimizing compiler for the Standard ML programming language. Send comments and questions to MLton@mlton.org. MLton COPYRIGHT NOTICE, LICENSE AND DISCLAIMER. Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh Jagannathan, and Stephen Weeks. Copyright (C) 1997-2000 by the NEC Research Institute Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the above copyright notice appear in all copies and that both the copyright notice and this permission notice and warranty disclaimer appear in supporting documentation, and that the name of the above copyright holders, or their entities, not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission. The above copyright holders disclaim all warranties with regard to this software, including all implied warranties of merchantability and fitness. In no event shall the above copyright holders be liable for any special, indirect or consequential damages or any damages whatsoever resulting from loss of use, data or profits, whether in an action of contract, negligence or other tortious action, arising out of or in connection with the use or performance of this software. core_kernel-113.00.00/Makefile000066400000000000000000000025121256461164500157560ustar00rootroot00000000000000# Generic Makefile for oasis project # Set to setup.exe for the release SETUP := setup.exe # Default rule default: build # Setup for the development version setup-dev.exe: _oasis setup.ml grep -v '^#' setup.ml > setup_dev.ml ocamlfind ocamlopt -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || ocamlfind ocamlc -o $@ -linkpkg -package ocamlbuild,oasis.dynrun setup_dev.ml || true rm -f setup_dev.* # Setup for the release setup.exe: setup.ml ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $< rm -f setup.cmx setup.cmi setup.o setup.obj setup.cmo build: $(SETUP) setup.data ./$(SETUP) -build $(BUILDFLAGS) doc: $(SETUP) setup.data build ./$(SETUP) -doc $(DOCFLAGS) test: $(SETUP) setup.data build ./$(SETUP) -test $(TESTFLAGS) all: $(SETUP) ./$(SETUP) -all $(ALLFLAGS) install: $(SETUP) setup.data ./$(SETUP) -install $(INSTALLFLAGS) uninstall: $(SETUP) setup.data ./$(SETUP) -uninstall $(UNINSTALLFLAGS) reinstall: $(SETUP) setup.data ./$(SETUP) -reinstall $(REINSTALLFLAGS) clean: $(SETUP) ./$(SETUP) -clean $(CLEANFLAGS) distclean: $(SETUP) ./$(SETUP) -distclean $(DISTCLEANFLAGS) configure: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) setup.data: $(SETUP) ./$(SETUP) -configure $(CONFIGUREFLAGS) .PHONY: default build doc test all install uninstall reinstall clean distclean configure core_kernel-113.00.00/README.md000066400000000000000000000012741256461164500156010ustar00rootroot00000000000000Core is an industrial-strength alternative to the OCaml standard library. It was developed by Jane Street, which is the largest industrial user of OCaml. Core_kernel is the system-independent part of Core. It is aimed for cases when the full Core is not available, such as in Javascript. It provides an overlay on the usual namespace, so the best way to use Core is to start your file with: ```ocaml open Core_kernel.Std ``` Please report bugs and feature requests on [GitHub](https://github.com/janestreet/core_kernel). For everything else you can contact us at . You can find all of Jane Street's open-source libraries on [GitHub](https://github.com/janestreet). core_kernel-113.00.00/THIRD-PARTY.txt000066400000000000000000000013601256461164500166260ustar00rootroot00000000000000The repository contains 3rd-party code in the following locations and under the following licenses: - type_conv, sexplib and bin_prot: based on Tywith, by Martin Sandin. License can be found in base/sexplib/LICENSE-Tywith.txt, base/type_conv/LICENSE-Tywith.txt, and base/bin_prot/LICENSE-Tywith.txt. - Core's implementation of union-find: based on an implementation by Henry Matthew Fluet, Suresh Jagannathan, and Stephen Weeks. License can be found in base/core/MLton-license. - Various Core libraries are based on INRIA's OCaml distribution. Relicensed under Apache 2.0, as permitted under the Caml License for Consortium members: http://caml.inria.fr/consortium/license.en.html See also the disclaimer INRIA-DISCLAIMER.txt. core_kernel-113.00.00/_oasis000066400000000000000000000267141256461164500155300ustar00rootroot00000000000000OASISFormat: 0.3 OCamlVersion: >= 4.00.1 FindlibVersion: >= 1.3.2 Name: core_kernel Version: 113.00.00 Synopsis: Jane Street Capital's standard library overlay Authors: Jane Street Group, LLC Copyrights: (C) 2008-2013 Jane Street Group LLC Maintainers: Jane Street Group, LLC License: Apache-2.0 LicenseFile: LICENSE.txt Homepage: https://github.com/janestreet/core_kernel Plugins: StdFiles (0.3), DevFiles (0.3), META (0.3) XStdFilesAUTHORS: false XStdFilesREADME: false BuildTools: ocamlbuild, camlp4o Description: The Core suite of libraries is an industrial strength alternative to OCaml's standard library that was developed by Jane Street, the largest industrial user of OCaml. Flag caml_modify_test Description: Enable caml modify tests Default$: flag(ld_wrap_possible) PreConfCommand: config/detect.sh PostConfCommand: config/discover.sh $ocamlc src/config.mlh src/config.h PreDistCleanCommand: $rm src/config.mlh src/config.h Library core_kernel Path: src FindlibName: core_kernel Pack: true Modules: Applicative, Applicative_intf, Array_permute, Avltree, Backtrace, Bag, Bigbuffer_internal, Bigbuffer, Bigstring_marshal, Bigstring, Bigsubstring, Binable0, Binable, Binary_packing, Binary_searchable, Binary_searchable_intf, Blang, Blit, Blit_intf, Bool, Bounded_int_table, Bucket, Byte_units, Caml, Common, Commutative_group, Comparable_intf, Comparable, Comparator, Constrained_float, Container, Container_intf, Container_unit_tests, Core_arg, Core_array, Core_bin_prot, Core_bytes, Core_char, Core_field, Core_gc, Core_gc_unit_tests, Core_hashtbl_intf, Core_hashtbl, Core_int32, Core_int63, Core_int64, Core_int, Core_lazy, Core_list, Core_list_unit_tests, Core_map_intf, Core_map, Core_map_bench, Core_map_unit_tests, Core_nativeint, Core_printexc, Core_printf, Core_queue, Core_queue_debug, Core_queue_unit_tests, Core_random, Core_set_intf, Core_set, Core_set_unit_tests, Core_sexp, Core_stack, Core_string, Core_weak, Day_of_week, Debug, Decimal, Deque, Dequeue, Doubly_linked, Either, Either_intf, Equal, Error, Exn, Fdeque, Fheap, Flags_intf, Flags, Flat_array, Flat_array_debug, Flat_array_unit_tests, Flat_queue, Flat_queue_debug, Flat_queue_unit_tests, Floatable, Float_intf, Float, Float_robust_compare, Fn, Force_once, Fqueue, Hashable, Hash_heap, Hash_queue, Hash_set_intf, Hash_set, Hashtbl_unit_tests, Heap_block, Heap_intf, Heap, Hex_lexer, Host_and_port, Identifiable, In_channel, Info, Info_unit_tests, Intable, Int_conversions, Interfaces, Int_intf, Int_math, Int_pow2, Int_replace_polymorphic_compare, Int_set, Invariant, Invariant_intf, Linked_queue, Linked_stack, Make_substring, Memo, Monad, Monad_intf, Month, Never_returns, No_polymorphic_compare, Nothing0, Nothing, Obj_array, Only_in_test, Option, Ordered_collection_common, Ordering, Or_error, Out_channel, Percent, Perms, Pid, Poly, Polymorphic_compare_intf, Polymorphic_compare, Pool, Pool_intf, Pool_unit_tests, Pooled_hashtbl, Pooled_hashtbl_unit_test, Pow_overflow_bounds, Pretty_printer, Quickcheck, Quickcheck_generator, Quickcheck_intf, Quickcheck_observer, Quickcheck_unit_tests, Raw_quickcheck_generator, Raw_quickcheck_observer, Ref, Result, Robustly_comparable, Rope, Sequence, Set_once, Sexpable, Source_code_position0, Source_code_position, Stable_containers, Stable_internal, Stable_module_types, Stable, Stable_unit_test_intf, Stable_unit_test, Stack_intf, Stack_unit_tests, Staged, Std_common, Std_internal, Std_kernel, Std, Stringable, String_id, Substring_intf, Substring, T, Thread_safe_queue, Time_ns, Time_ns_alternate_sexp, Timing_wheel_intf, Timing_wheel_ns, Timing_wheel_ns_unit_tests, Timing_wheel_unit_tests, Total_map, Tuple, Tuple_type, Tuple_type_intf, Type_equal, Type_immediacy, Type_immediacy_conv_unit_tests, Type_immediacy_witness_unit_tests, Union_find, Unique_id_intf, Unique_id, Unit, Univ_map, Univ_map_intf, Univ, Unpack_buffer, Validated_intf, Validated, Validate, With_return, Word_size CSources: bigstring_marshal_stubs.c, bigstring_stubs.c, core_array_stubs.c, core_gc_stubs.c, hash_stubs.c, heap_block_stubs.c, config.h, core_params.h, exn_stubs.c, int_math_stubs.c, core_bigstring.h, ocaml_utils.h, jane_common.h, time_ns_stubs.c, time_ns_stubs.h BuildDepends: bigarray, bin_prot, bin_prot.syntax, comparelib.syntax, custom_printf, custom_printf.syntax, enumerate, enumerate.syntax, fieldslib, fieldslib.syntax, herelib, herelib.syntax, pa_bench, pa_bench.syntax, pa_test, pa_test.syntax, pa_ounit, pa_ounit.syntax, pa_pipebang, sexplib, sexplib.syntax, typerep_lib, typerep_lib.syntax, unix, variantslib, variantslib.syntax XMETARequires: bin_prot, custom_printf, variantslib, sexplib, enumerate, fieldslib, bigarray, pa_bench, pa_ounit, pa_test, typerep_lib, unix Library check_caml_modify Build$: flag(caml_modify_test) Install$: flag(caml_modify_test) Path: check_caml_modify FindlibName: check_caml_modify FindlibParent: core_kernel Pack: true Modules: Caml_modify CSources: caml_modify_stub.c BuildDepends: pa_ounit, pa_ounit.syntax XMETARequires: pa_ounit Executable pool_caml_modify_check Path: test Build$: flag(tests) && flag(caml_modify_test) Install: false CompiledObject: best MainIs: pool_caml_modify_check.ml BuildDepends: core_kernel, core_kernel.check_caml_modify Test test_pool_caml_modify_check Command: $pool_caml_modify_check TestTools: pool_caml_modify_check Run$: flag(tests) && flag(caml_modify_test) core_kernel-113.00.00/_tags000066400000000000000000000637571256461164500153600ustar00rootroot00000000000000 : pa_ounit_lib(core_kernel) : pa_ounit_lib(core_kernel.check_caml_modify) <**/*.ml{,i}> : syntax_camlp4o "src/time_ns.ml" : mlh, package(camlp4.macro) "src/bigstring.ml" : mlh, package(camlp4.macro) "src/bigstring_marshal.ml" : mlh, package(camlp4.macro) "src/binary_packing.ml" : mlh, package(camlp4.macro) "src/core_int63.ml" : mlh, package(camlp4.macro) "src/core_int63.mli" : mlh, package(camlp4.macro) "src/pool.ml" : mlh, package(camlp4.macro) "src/pow_overflow_bounds.ml" : mlh, package(camlp4.macro) "src/quickcheck_unit_tests.ml" : mlh, package(camlp4.macro) "src/float.ml" : mlh, package(camlp4.macro) : caml_modify_wrapper # OASIS_START # DO NOT EDIT (digest: ce0f9977640c39cd5389c6b4a22b8cd8) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process true: annot, bin_annot <**/.svn>: -traverse <**/.svn>: not_hygienic ".bzr": -traverse ".bzr": not_hygienic ".hg": -traverse ".hg": not_hygienic ".git": -traverse ".git": not_hygienic "_darcs": -traverse "_darcs": not_hygienic # Library core_kernel "src/core_kernel.cmxs": use_core_kernel "src/applicative.cmx": for-pack(Core_kernel) "src/applicative_intf.cmx": for-pack(Core_kernel) "src/array_permute.cmx": for-pack(Core_kernel) "src/avltree.cmx": for-pack(Core_kernel) "src/backtrace.cmx": for-pack(Core_kernel) "src/bag.cmx": for-pack(Core_kernel) "src/bigbuffer_internal.cmx": for-pack(Core_kernel) "src/bigbuffer.cmx": for-pack(Core_kernel) "src/bigstring_marshal.cmx": for-pack(Core_kernel) "src/bigstring.cmx": for-pack(Core_kernel) "src/bigsubstring.cmx": for-pack(Core_kernel) "src/binable0.cmx": for-pack(Core_kernel) "src/binable.cmx": for-pack(Core_kernel) "src/binary_packing.cmx": for-pack(Core_kernel) "src/binary_searchable.cmx": for-pack(Core_kernel) "src/binary_searchable_intf.cmx": for-pack(Core_kernel) "src/blang.cmx": for-pack(Core_kernel) "src/blit.cmx": for-pack(Core_kernel) "src/blit_intf.cmx": for-pack(Core_kernel) "src/bool.cmx": for-pack(Core_kernel) "src/bounded_int_table.cmx": for-pack(Core_kernel) "src/bucket.cmx": for-pack(Core_kernel) "src/byte_units.cmx": for-pack(Core_kernel) "src/caml.cmx": for-pack(Core_kernel) "src/common.cmx": for-pack(Core_kernel) "src/commutative_group.cmx": for-pack(Core_kernel) "src/comparable_intf.cmx": for-pack(Core_kernel) "src/comparable.cmx": for-pack(Core_kernel) "src/comparator.cmx": for-pack(Core_kernel) "src/constrained_float.cmx": for-pack(Core_kernel) "src/container.cmx": for-pack(Core_kernel) "src/container_intf.cmx": for-pack(Core_kernel) "src/container_unit_tests.cmx": for-pack(Core_kernel) "src/core_arg.cmx": for-pack(Core_kernel) "src/core_array.cmx": for-pack(Core_kernel) "src/core_bin_prot.cmx": for-pack(Core_kernel) "src/core_bytes.cmx": for-pack(Core_kernel) "src/core_char.cmx": for-pack(Core_kernel) "src/core_field.cmx": for-pack(Core_kernel) "src/core_gc.cmx": for-pack(Core_kernel) "src/core_gc_unit_tests.cmx": for-pack(Core_kernel) "src/core_hashtbl_intf.cmx": for-pack(Core_kernel) "src/core_hashtbl.cmx": for-pack(Core_kernel) "src/core_int32.cmx": for-pack(Core_kernel) "src/core_int63.cmx": for-pack(Core_kernel) "src/core_int64.cmx": for-pack(Core_kernel) "src/core_int.cmx": for-pack(Core_kernel) "src/core_lazy.cmx": for-pack(Core_kernel) "src/core_list.cmx": for-pack(Core_kernel) "src/core_list_unit_tests.cmx": for-pack(Core_kernel) "src/core_map_intf.cmx": for-pack(Core_kernel) "src/core_map.cmx": for-pack(Core_kernel) "src/core_map_bench.cmx": for-pack(Core_kernel) "src/core_map_unit_tests.cmx": for-pack(Core_kernel) "src/core_nativeint.cmx": for-pack(Core_kernel) "src/core_printexc.cmx": for-pack(Core_kernel) "src/core_printf.cmx": for-pack(Core_kernel) "src/core_queue.cmx": for-pack(Core_kernel) "src/core_queue_debug.cmx": for-pack(Core_kernel) "src/core_queue_unit_tests.cmx": for-pack(Core_kernel) "src/core_random.cmx": for-pack(Core_kernel) "src/core_set_intf.cmx": for-pack(Core_kernel) "src/core_set.cmx": for-pack(Core_kernel) "src/core_set_unit_tests.cmx": for-pack(Core_kernel) "src/core_sexp.cmx": for-pack(Core_kernel) "src/core_stack.cmx": for-pack(Core_kernel) "src/core_string.cmx": for-pack(Core_kernel) "src/core_weak.cmx": for-pack(Core_kernel) "src/day_of_week.cmx": for-pack(Core_kernel) "src/debug.cmx": for-pack(Core_kernel) "src/decimal.cmx": for-pack(Core_kernel) "src/deque.cmx": for-pack(Core_kernel) "src/dequeue.cmx": for-pack(Core_kernel) "src/doubly_linked.cmx": for-pack(Core_kernel) "src/either.cmx": for-pack(Core_kernel) "src/either_intf.cmx": for-pack(Core_kernel) "src/equal.cmx": for-pack(Core_kernel) "src/error.cmx": for-pack(Core_kernel) "src/exn.cmx": for-pack(Core_kernel) "src/fdeque.cmx": for-pack(Core_kernel) "src/fheap.cmx": for-pack(Core_kernel) "src/flags_intf.cmx": for-pack(Core_kernel) "src/flags.cmx": for-pack(Core_kernel) "src/flat_array.cmx": for-pack(Core_kernel) "src/flat_array_debug.cmx": for-pack(Core_kernel) "src/flat_array_unit_tests.cmx": for-pack(Core_kernel) "src/flat_queue.cmx": for-pack(Core_kernel) "src/flat_queue_debug.cmx": for-pack(Core_kernel) "src/flat_queue_unit_tests.cmx": for-pack(Core_kernel) "src/floatable.cmx": for-pack(Core_kernel) "src/float_intf.cmx": for-pack(Core_kernel) "src/float.cmx": for-pack(Core_kernel) "src/float_robust_compare.cmx": for-pack(Core_kernel) "src/fn.cmx": for-pack(Core_kernel) "src/force_once.cmx": for-pack(Core_kernel) "src/fqueue.cmx": for-pack(Core_kernel) "src/hashable.cmx": for-pack(Core_kernel) "src/hash_heap.cmx": for-pack(Core_kernel) "src/hash_queue.cmx": for-pack(Core_kernel) "src/hash_set_intf.cmx": for-pack(Core_kernel) "src/hash_set.cmx": for-pack(Core_kernel) "src/hashtbl_unit_tests.cmx": for-pack(Core_kernel) "src/heap_block.cmx": for-pack(Core_kernel) "src/heap_intf.cmx": for-pack(Core_kernel) "src/heap.cmx": for-pack(Core_kernel) "src/hex_lexer.cmx": for-pack(Core_kernel) "src/host_and_port.cmx": for-pack(Core_kernel) "src/identifiable.cmx": for-pack(Core_kernel) "src/in_channel.cmx": for-pack(Core_kernel) "src/info.cmx": for-pack(Core_kernel) "src/info_unit_tests.cmx": for-pack(Core_kernel) "src/intable.cmx": for-pack(Core_kernel) "src/int_conversions.cmx": for-pack(Core_kernel) "src/interfaces.cmx": for-pack(Core_kernel) "src/int_intf.cmx": for-pack(Core_kernel) "src/int_math.cmx": for-pack(Core_kernel) "src/int_pow2.cmx": for-pack(Core_kernel) "src/int_replace_polymorphic_compare.cmx": for-pack(Core_kernel) "src/int_set.cmx": for-pack(Core_kernel) "src/invariant.cmx": for-pack(Core_kernel) "src/invariant_intf.cmx": for-pack(Core_kernel) "src/linked_queue.cmx": for-pack(Core_kernel) "src/linked_stack.cmx": for-pack(Core_kernel) "src/make_substring.cmx": for-pack(Core_kernel) "src/memo.cmx": for-pack(Core_kernel) "src/monad.cmx": for-pack(Core_kernel) "src/monad_intf.cmx": for-pack(Core_kernel) "src/month.cmx": for-pack(Core_kernel) "src/never_returns.cmx": for-pack(Core_kernel) "src/no_polymorphic_compare.cmx": for-pack(Core_kernel) "src/nothing0.cmx": for-pack(Core_kernel) "src/nothing.cmx": for-pack(Core_kernel) "src/obj_array.cmx": for-pack(Core_kernel) "src/only_in_test.cmx": for-pack(Core_kernel) "src/option.cmx": for-pack(Core_kernel) "src/ordered_collection_common.cmx": for-pack(Core_kernel) "src/ordering.cmx": for-pack(Core_kernel) "src/or_error.cmx": for-pack(Core_kernel) "src/out_channel.cmx": for-pack(Core_kernel) "src/percent.cmx": for-pack(Core_kernel) "src/perms.cmx": for-pack(Core_kernel) "src/pid.cmx": for-pack(Core_kernel) "src/poly.cmx": for-pack(Core_kernel) "src/polymorphic_compare_intf.cmx": for-pack(Core_kernel) "src/polymorphic_compare.cmx": for-pack(Core_kernel) "src/pool.cmx": for-pack(Core_kernel) "src/pool_intf.cmx": for-pack(Core_kernel) "src/pool_unit_tests.cmx": for-pack(Core_kernel) "src/pooled_hashtbl.cmx": for-pack(Core_kernel) "src/pooled_hashtbl_unit_test.cmx": for-pack(Core_kernel) "src/pow_overflow_bounds.cmx": for-pack(Core_kernel) "src/pretty_printer.cmx": for-pack(Core_kernel) "src/quickcheck.cmx": for-pack(Core_kernel) "src/quickcheck_generator.cmx": for-pack(Core_kernel) "src/quickcheck_intf.cmx": for-pack(Core_kernel) "src/quickcheck_observer.cmx": for-pack(Core_kernel) "src/quickcheck_unit_tests.cmx": for-pack(Core_kernel) "src/raw_quickcheck_generator.cmx": for-pack(Core_kernel) "src/raw_quickcheck_observer.cmx": for-pack(Core_kernel) "src/ref.cmx": for-pack(Core_kernel) "src/result.cmx": for-pack(Core_kernel) "src/robustly_comparable.cmx": for-pack(Core_kernel) "src/rope.cmx": for-pack(Core_kernel) "src/sequence.cmx": for-pack(Core_kernel) "src/set_once.cmx": for-pack(Core_kernel) "src/sexpable.cmx": for-pack(Core_kernel) "src/source_code_position0.cmx": for-pack(Core_kernel) "src/source_code_position.cmx": for-pack(Core_kernel) "src/stable_containers.cmx": for-pack(Core_kernel) "src/stable_internal.cmx": for-pack(Core_kernel) "src/stable_module_types.cmx": for-pack(Core_kernel) "src/stable.cmx": for-pack(Core_kernel) "src/stable_unit_test_intf.cmx": for-pack(Core_kernel) "src/stable_unit_test.cmx": for-pack(Core_kernel) "src/stack_intf.cmx": for-pack(Core_kernel) "src/stack_unit_tests.cmx": for-pack(Core_kernel) "src/staged.cmx": for-pack(Core_kernel) "src/std_common.cmx": for-pack(Core_kernel) "src/std_internal.cmx": for-pack(Core_kernel) "src/std_kernel.cmx": for-pack(Core_kernel) "src/std.cmx": for-pack(Core_kernel) "src/stringable.cmx": for-pack(Core_kernel) "src/string_id.cmx": for-pack(Core_kernel) "src/substring_intf.cmx": for-pack(Core_kernel) "src/substring.cmx": for-pack(Core_kernel) "src/t.cmx": for-pack(Core_kernel) "src/thread_safe_queue.cmx": for-pack(Core_kernel) "src/time_ns.cmx": for-pack(Core_kernel) "src/time_ns_alternate_sexp.cmx": for-pack(Core_kernel) "src/timing_wheel_intf.cmx": for-pack(Core_kernel) "src/timing_wheel_ns.cmx": for-pack(Core_kernel) "src/timing_wheel_ns_unit_tests.cmx": for-pack(Core_kernel) "src/timing_wheel_unit_tests.cmx": for-pack(Core_kernel) "src/total_map.cmx": for-pack(Core_kernel) "src/tuple.cmx": for-pack(Core_kernel) "src/tuple_type.cmx": for-pack(Core_kernel) "src/tuple_type_intf.cmx": for-pack(Core_kernel) "src/type_equal.cmx": for-pack(Core_kernel) "src/type_immediacy.cmx": for-pack(Core_kernel) "src/type_immediacy_conv_unit_tests.cmx": for-pack(Core_kernel) "src/type_immediacy_witness_unit_tests.cmx": for-pack(Core_kernel) "src/union_find.cmx": for-pack(Core_kernel) "src/unique_id_intf.cmx": for-pack(Core_kernel) "src/unique_id.cmx": for-pack(Core_kernel) "src/unit.cmx": for-pack(Core_kernel) "src/univ_map.cmx": for-pack(Core_kernel) "src/univ_map_intf.cmx": for-pack(Core_kernel) "src/univ.cmx": for-pack(Core_kernel) "src/unpack_buffer.cmx": for-pack(Core_kernel) "src/validated_intf.cmx": for-pack(Core_kernel) "src/validated.cmx": for-pack(Core_kernel) "src/validate.cmx": for-pack(Core_kernel) "src/with_return.cmx": for-pack(Core_kernel) "src/word_size.cmx": for-pack(Core_kernel) : use_libcore_kernel_stubs : package(bigarray) : package(bin_prot) : package(bin_prot.syntax) : package(comparelib.syntax) : package(custom_printf) : package(custom_printf.syntax) : package(enumerate) : package(enumerate.syntax) : package(fieldslib) : package(fieldslib.syntax) : package(herelib) : package(herelib.syntax) : package(pa_bench) : package(pa_bench.syntax) : package(pa_ounit) : package(pa_ounit.syntax) : package(pa_pipebang) : package(pa_test) : package(pa_test.syntax) : package(sexplib) : package(sexplib.syntax) : package(typerep_lib) : package(typerep_lib.syntax) : package(unix) : package(variantslib) : package(variantslib.syntax) "src/bigstring_marshal_stubs.c": package(bigarray) "src/bigstring_marshal_stubs.c": package(bin_prot) "src/bigstring_marshal_stubs.c": package(bin_prot.syntax) "src/bigstring_marshal_stubs.c": package(comparelib.syntax) "src/bigstring_marshal_stubs.c": package(custom_printf) "src/bigstring_marshal_stubs.c": package(custom_printf.syntax) "src/bigstring_marshal_stubs.c": package(enumerate) "src/bigstring_marshal_stubs.c": package(enumerate.syntax) "src/bigstring_marshal_stubs.c": package(fieldslib) "src/bigstring_marshal_stubs.c": package(fieldslib.syntax) "src/bigstring_marshal_stubs.c": package(herelib) "src/bigstring_marshal_stubs.c": package(herelib.syntax) "src/bigstring_marshal_stubs.c": package(pa_bench) "src/bigstring_marshal_stubs.c": package(pa_bench.syntax) "src/bigstring_marshal_stubs.c": package(pa_ounit) "src/bigstring_marshal_stubs.c": package(pa_ounit.syntax) "src/bigstring_marshal_stubs.c": package(pa_pipebang) "src/bigstring_marshal_stubs.c": package(pa_test) "src/bigstring_marshal_stubs.c": package(pa_test.syntax) "src/bigstring_marshal_stubs.c": package(sexplib) "src/bigstring_marshal_stubs.c": package(sexplib.syntax) "src/bigstring_marshal_stubs.c": package(typerep_lib) "src/bigstring_marshal_stubs.c": package(typerep_lib.syntax) "src/bigstring_marshal_stubs.c": package(unix) "src/bigstring_marshal_stubs.c": package(variantslib) "src/bigstring_marshal_stubs.c": package(variantslib.syntax) "src/bigstring_stubs.c": package(bigarray) "src/bigstring_stubs.c": package(bin_prot) "src/bigstring_stubs.c": package(bin_prot.syntax) "src/bigstring_stubs.c": package(comparelib.syntax) "src/bigstring_stubs.c": package(custom_printf) "src/bigstring_stubs.c": package(custom_printf.syntax) "src/bigstring_stubs.c": package(enumerate) "src/bigstring_stubs.c": package(enumerate.syntax) "src/bigstring_stubs.c": package(fieldslib) "src/bigstring_stubs.c": package(fieldslib.syntax) "src/bigstring_stubs.c": package(herelib) "src/bigstring_stubs.c": package(herelib.syntax) "src/bigstring_stubs.c": package(pa_bench) "src/bigstring_stubs.c": package(pa_bench.syntax) "src/bigstring_stubs.c": package(pa_ounit) "src/bigstring_stubs.c": package(pa_ounit.syntax) "src/bigstring_stubs.c": package(pa_pipebang) "src/bigstring_stubs.c": package(pa_test) "src/bigstring_stubs.c": package(pa_test.syntax) "src/bigstring_stubs.c": package(sexplib) "src/bigstring_stubs.c": package(sexplib.syntax) "src/bigstring_stubs.c": package(typerep_lib) "src/bigstring_stubs.c": package(typerep_lib.syntax) "src/bigstring_stubs.c": package(unix) "src/bigstring_stubs.c": package(variantslib) "src/bigstring_stubs.c": package(variantslib.syntax) "src/core_array_stubs.c": package(bigarray) "src/core_array_stubs.c": package(bin_prot) "src/core_array_stubs.c": package(bin_prot.syntax) "src/core_array_stubs.c": package(comparelib.syntax) "src/core_array_stubs.c": package(custom_printf) "src/core_array_stubs.c": package(custom_printf.syntax) "src/core_array_stubs.c": package(enumerate) "src/core_array_stubs.c": package(enumerate.syntax) "src/core_array_stubs.c": package(fieldslib) "src/core_array_stubs.c": package(fieldslib.syntax) "src/core_array_stubs.c": package(herelib) "src/core_array_stubs.c": package(herelib.syntax) "src/core_array_stubs.c": package(pa_bench) "src/core_array_stubs.c": package(pa_bench.syntax) "src/core_array_stubs.c": package(pa_ounit) "src/core_array_stubs.c": package(pa_ounit.syntax) "src/core_array_stubs.c": package(pa_pipebang) "src/core_array_stubs.c": package(pa_test) "src/core_array_stubs.c": package(pa_test.syntax) "src/core_array_stubs.c": package(sexplib) "src/core_array_stubs.c": package(sexplib.syntax) "src/core_array_stubs.c": package(typerep_lib) "src/core_array_stubs.c": package(typerep_lib.syntax) "src/core_array_stubs.c": package(unix) "src/core_array_stubs.c": package(variantslib) "src/core_array_stubs.c": package(variantslib.syntax) "src/core_gc_stubs.c": package(bigarray) "src/core_gc_stubs.c": package(bin_prot) "src/core_gc_stubs.c": package(bin_prot.syntax) "src/core_gc_stubs.c": package(comparelib.syntax) "src/core_gc_stubs.c": package(custom_printf) "src/core_gc_stubs.c": package(custom_printf.syntax) "src/core_gc_stubs.c": package(enumerate) "src/core_gc_stubs.c": package(enumerate.syntax) "src/core_gc_stubs.c": package(fieldslib) "src/core_gc_stubs.c": package(fieldslib.syntax) "src/core_gc_stubs.c": package(herelib) "src/core_gc_stubs.c": package(herelib.syntax) "src/core_gc_stubs.c": package(pa_bench) "src/core_gc_stubs.c": package(pa_bench.syntax) "src/core_gc_stubs.c": package(pa_ounit) "src/core_gc_stubs.c": package(pa_ounit.syntax) "src/core_gc_stubs.c": package(pa_pipebang) "src/core_gc_stubs.c": package(pa_test) "src/core_gc_stubs.c": package(pa_test.syntax) "src/core_gc_stubs.c": package(sexplib) "src/core_gc_stubs.c": package(sexplib.syntax) "src/core_gc_stubs.c": package(typerep_lib) "src/core_gc_stubs.c": package(typerep_lib.syntax) "src/core_gc_stubs.c": package(unix) "src/core_gc_stubs.c": package(variantslib) "src/core_gc_stubs.c": package(variantslib.syntax) "src/hash_stubs.c": package(bigarray) "src/hash_stubs.c": package(bin_prot) "src/hash_stubs.c": package(bin_prot.syntax) "src/hash_stubs.c": package(comparelib.syntax) "src/hash_stubs.c": package(custom_printf) "src/hash_stubs.c": package(custom_printf.syntax) "src/hash_stubs.c": package(enumerate) "src/hash_stubs.c": package(enumerate.syntax) "src/hash_stubs.c": package(fieldslib) "src/hash_stubs.c": package(fieldslib.syntax) "src/hash_stubs.c": package(herelib) "src/hash_stubs.c": package(herelib.syntax) "src/hash_stubs.c": package(pa_bench) "src/hash_stubs.c": package(pa_bench.syntax) "src/hash_stubs.c": package(pa_ounit) "src/hash_stubs.c": package(pa_ounit.syntax) "src/hash_stubs.c": package(pa_pipebang) "src/hash_stubs.c": package(pa_test) "src/hash_stubs.c": package(pa_test.syntax) "src/hash_stubs.c": package(sexplib) "src/hash_stubs.c": package(sexplib.syntax) "src/hash_stubs.c": package(typerep_lib) "src/hash_stubs.c": package(typerep_lib.syntax) "src/hash_stubs.c": package(unix) "src/hash_stubs.c": package(variantslib) "src/hash_stubs.c": package(variantslib.syntax) "src/heap_block_stubs.c": package(bigarray) "src/heap_block_stubs.c": package(bin_prot) "src/heap_block_stubs.c": package(bin_prot.syntax) "src/heap_block_stubs.c": package(comparelib.syntax) "src/heap_block_stubs.c": package(custom_printf) "src/heap_block_stubs.c": package(custom_printf.syntax) "src/heap_block_stubs.c": package(enumerate) "src/heap_block_stubs.c": package(enumerate.syntax) "src/heap_block_stubs.c": package(fieldslib) "src/heap_block_stubs.c": package(fieldslib.syntax) "src/heap_block_stubs.c": package(herelib) "src/heap_block_stubs.c": package(herelib.syntax) "src/heap_block_stubs.c": package(pa_bench) "src/heap_block_stubs.c": package(pa_bench.syntax) "src/heap_block_stubs.c": package(pa_ounit) "src/heap_block_stubs.c": package(pa_ounit.syntax) "src/heap_block_stubs.c": package(pa_pipebang) "src/heap_block_stubs.c": package(pa_test) "src/heap_block_stubs.c": package(pa_test.syntax) "src/heap_block_stubs.c": package(sexplib) "src/heap_block_stubs.c": package(sexplib.syntax) "src/heap_block_stubs.c": package(typerep_lib) "src/heap_block_stubs.c": package(typerep_lib.syntax) "src/heap_block_stubs.c": package(unix) "src/heap_block_stubs.c": package(variantslib) "src/heap_block_stubs.c": package(variantslib.syntax) "src/exn_stubs.c": package(bigarray) "src/exn_stubs.c": package(bin_prot) "src/exn_stubs.c": package(bin_prot.syntax) "src/exn_stubs.c": package(comparelib.syntax) "src/exn_stubs.c": package(custom_printf) "src/exn_stubs.c": package(custom_printf.syntax) "src/exn_stubs.c": package(enumerate) "src/exn_stubs.c": package(enumerate.syntax) "src/exn_stubs.c": package(fieldslib) "src/exn_stubs.c": package(fieldslib.syntax) "src/exn_stubs.c": package(herelib) "src/exn_stubs.c": package(herelib.syntax) "src/exn_stubs.c": package(pa_bench) "src/exn_stubs.c": package(pa_bench.syntax) "src/exn_stubs.c": package(pa_ounit) "src/exn_stubs.c": package(pa_ounit.syntax) "src/exn_stubs.c": package(pa_pipebang) "src/exn_stubs.c": package(pa_test) "src/exn_stubs.c": package(pa_test.syntax) "src/exn_stubs.c": package(sexplib) "src/exn_stubs.c": package(sexplib.syntax) "src/exn_stubs.c": package(typerep_lib) "src/exn_stubs.c": package(typerep_lib.syntax) "src/exn_stubs.c": package(unix) "src/exn_stubs.c": package(variantslib) "src/exn_stubs.c": package(variantslib.syntax) "src/int_math_stubs.c": package(bigarray) "src/int_math_stubs.c": package(bin_prot) "src/int_math_stubs.c": package(bin_prot.syntax) "src/int_math_stubs.c": package(comparelib.syntax) "src/int_math_stubs.c": package(custom_printf) "src/int_math_stubs.c": package(custom_printf.syntax) "src/int_math_stubs.c": package(enumerate) "src/int_math_stubs.c": package(enumerate.syntax) "src/int_math_stubs.c": package(fieldslib) "src/int_math_stubs.c": package(fieldslib.syntax) "src/int_math_stubs.c": package(herelib) "src/int_math_stubs.c": package(herelib.syntax) "src/int_math_stubs.c": package(pa_bench) "src/int_math_stubs.c": package(pa_bench.syntax) "src/int_math_stubs.c": package(pa_ounit) "src/int_math_stubs.c": package(pa_ounit.syntax) "src/int_math_stubs.c": package(pa_pipebang) "src/int_math_stubs.c": package(pa_test) "src/int_math_stubs.c": package(pa_test.syntax) "src/int_math_stubs.c": package(sexplib) "src/int_math_stubs.c": package(sexplib.syntax) "src/int_math_stubs.c": package(typerep_lib) "src/int_math_stubs.c": package(typerep_lib.syntax) "src/int_math_stubs.c": package(unix) "src/int_math_stubs.c": package(variantslib) "src/int_math_stubs.c": package(variantslib.syntax) "src/time_ns_stubs.c": package(bigarray) "src/time_ns_stubs.c": package(bin_prot) "src/time_ns_stubs.c": package(bin_prot.syntax) "src/time_ns_stubs.c": package(comparelib.syntax) "src/time_ns_stubs.c": package(custom_printf) "src/time_ns_stubs.c": package(custom_printf.syntax) "src/time_ns_stubs.c": package(enumerate) "src/time_ns_stubs.c": package(enumerate.syntax) "src/time_ns_stubs.c": package(fieldslib) "src/time_ns_stubs.c": package(fieldslib.syntax) "src/time_ns_stubs.c": package(herelib) "src/time_ns_stubs.c": package(herelib.syntax) "src/time_ns_stubs.c": package(pa_bench) "src/time_ns_stubs.c": package(pa_bench.syntax) "src/time_ns_stubs.c": package(pa_ounit) "src/time_ns_stubs.c": package(pa_ounit.syntax) "src/time_ns_stubs.c": package(pa_pipebang) "src/time_ns_stubs.c": package(pa_test) "src/time_ns_stubs.c": package(pa_test.syntax) "src/time_ns_stubs.c": package(sexplib) "src/time_ns_stubs.c": package(sexplib.syntax) "src/time_ns_stubs.c": package(typerep_lib) "src/time_ns_stubs.c": package(typerep_lib.syntax) "src/time_ns_stubs.c": package(unix) "src/time_ns_stubs.c": package(variantslib) "src/time_ns_stubs.c": package(variantslib.syntax) # Library check_caml_modify "check_caml_modify/check_caml_modify.cmxs": use_check_caml_modify "check_caml_modify/caml_modify.cmx": for-pack(Check_caml_modify) : use_libcheck_caml_modify_stubs : package(pa_ounit) : package(pa_ounit.syntax) "check_caml_modify/caml_modify_stub.c": package(pa_ounit) "check_caml_modify/caml_modify_stub.c": package(pa_ounit.syntax) # Executable pool_caml_modify_check : package(bigarray) : package(bin_prot) : package(bin_prot.syntax) : package(comparelib.syntax) : package(custom_printf) : package(custom_printf.syntax) : package(enumerate) : package(enumerate.syntax) : package(fieldslib) : package(fieldslib.syntax) : package(herelib) : package(herelib.syntax) : package(pa_bench) : package(pa_bench.syntax) : package(pa_ounit) : package(pa_ounit.syntax) : package(pa_pipebang) : package(pa_test) : package(pa_test.syntax) : package(sexplib) : package(sexplib.syntax) : package(typerep_lib) : package(typerep_lib.syntax) : package(unix) : package(variantslib) : package(variantslib.syntax) : use_check_caml_modify : use_core_kernel : package(bigarray) : package(bin_prot) : package(bin_prot.syntax) : package(comparelib.syntax) : package(custom_printf) : package(custom_printf.syntax) : package(enumerate) : package(enumerate.syntax) : package(fieldslib) : package(fieldslib.syntax) : package(herelib) : package(herelib.syntax) : package(pa_bench) : package(pa_bench.syntax) : package(pa_ounit) : package(pa_ounit.syntax) : package(pa_pipebang) : package(pa_test) : package(pa_test.syntax) : package(sexplib) : package(sexplib.syntax) : package(typerep_lib) : package(typerep_lib.syntax) : package(unix) : package(variantslib) : package(variantslib.syntax) : use_check_caml_modify : use_core_kernel # OASIS_STOP core_kernel-113.00.00/bench/000077500000000000000000000000001256461164500153755ustar00rootroot00000000000000core_kernel-113.00.00/bench/array_queue.ml000066400000000000000000000061521256461164500202550ustar00rootroot00000000000000open Core_bench.Std open Core.Std let enqueue_tests = List.map [10;1_000_000] ~f:(fun n -> Bench.Test.create ~name:("enqueue " ^ Int.to_string n) (fun () -> let q = Queue.create () in for i = 1 to n do Queue.enqueue q i done)) ;; (* top unit argument is a cheap guard *) let enqueue_dequeue_mixed () = let test_size = 1_000_000 in let seed = Random.State.make [| 1; 2; 3; 4 |] in let choices = Array.init test_size ~f:(fun (_:int) -> Random.State.bool seed) in fun () -> let q = Queue.create () in for i = 1 to test_size do Queue.enqueue q i done; Array.iteri choices ~f:(fun i should_dequeue -> if should_dequeue then ignore (Queue.dequeue q) else Queue.enqueue q i) ;; let queue_pipeline () = let q1 = Queue.create () in let q2 = Queue.create () in let q3 = Queue.create () in let q4 = Queue.create () in let q5 = Queue.create () in fun () -> Queue.enqueue q1 1; Queue.blit_transfer ~src:q1 ~dst:q2 (); Queue.blit_transfer ~src:q2 ~dst:q3 (); Queue.blit_transfer ~src:q3 ~dst:q4 (); Queue.blit_transfer ~src:q4 ~dst:q5 (); ignore (Queue.dequeue_exn q5); ;; let blit_transfer_tests = List.bind [ 0; 1; 2; 4; 8; 16; 32; 64; 128 ] (fun len -> let half_len = len / 2 in let src = Queue.create () in let dst = Queue.create () in for _i = 1 to len do Queue.enqueue src 0; done; for _i = 1 to half_len do ignore (Queue.dequeue_exn src); done; for _i = 1 to half_len do Queue.enqueue src 0; done; [ Bench.Test.create ~name:(String.concat ["blit_transfer "; Int.to_string len]) (fun () -> Queue.blit_transfer ~src ~dst (); Queue.blit_transfer ~src:dst ~dst:src ()) ] ) ;; let tests = [ Bench.Test.create ~name:"enqueue_dequeue_mixed" (enqueue_dequeue_mixed ()) ; Bench.Test.create ~name:"pipeline" (queue_pipeline ()) ] @ blit_transfer_tests @ enqueue_tests @ (let args = List.init 10 ~f:(fun i -> Float.iround_nearest_exn (2. ** Float.of_int i)) in [ Bench.Test.create_indexed ~name:"Queue.enqueue + dequeue" ~args (fun num_elts -> let t = Queue.create () in for _i = 1 to num_elts do Queue.enqueue t (); done; stage (fun () -> Queue.enqueue t (); Queue.dequeue_exn t)) ; Bench.Test.create_indexed ~name:"Linked_queue.enqueue + dequeue" ~args (fun num_elts -> let t = Linked_queue.create () in for _i = 1 to num_elts do Linked_queue.enqueue t (); done; stage (fun () -> Linked_queue.enqueue t (); Linked_queue.dequeue_exn t)) ; Bench.Test.create_indexed ~name:"Deque.enqueue + dequeue" ~args (fun num_elts -> let t = Deque.create () in for _i = 1 to num_elts do Deque.enqueue_front t (); done; stage (fun () -> Deque.enqueue_front t (); Deque.dequeue_front_exn t)) ]) ;; let () = Command.run (Bench.make_command tests) core_kernel-113.00.00/bench/hashtbl_bench.ml000066400000000000000000000010741256461164500205150ustar00rootroot00000000000000open Core.Std open Core_bench.Std let mem_test = let table = List.init 100_000 ~f:(fun i -> (i, i)) |> Int.Table.of_alist_exn in Bench.Test.create ~name:"Hashtbl.mem" (fun () -> ignore (Hashtbl.mem table (Random.int 1_000_000))) let find_exn_test = let table = List.init 100_000 ~f:(fun i -> (i, i)) |> Int.Table.of_alist_exn in Bench.Test.create ~name:"Hashtbl.find_exn" (fun () -> ignore (Hashtbl.find_exn table (Random.int 100_000))) let tests = [ mem_test ; find_exn_test ] let () = Command.run (Bench.make_command tests) core_kernel-113.00.00/bench/immediate_bench.ml000066400000000000000000000005731256461164500210310ustar00rootroot00000000000000open Core.Std open Core_bench.Std module Always = Type_immediacy.Always module M = struct type t = A | B | C with typerep let always = Option.value_exn (Always.of_typerep typerep_of_t) end let tests = [ Bench.Test.create ~name:"Always.value_as_int" (fun () -> ignore (Always.value_as_int M.always M.A)) ] ;; let () = Command.run (Bench.make_command tests) core_kernel-113.00.00/bench/pooled_hashtbl.ml000066400000000000000000000036611256461164500207240ustar00rootroot00000000000000open Core.Std let n = 1_000_000 let times = 10 (** Benchmark the core Hashtbl *) let test_core () = let module Identity_table = Hashtbl.Make(struct include Int let hash x = x end) in let tbl = Identity_table.create ~size:(2*n) () in for i = 0 to n - 1 do Identity_table.set tbl ~key:i ~data:i; done; let start = Time.now () in let first_n = ref 0 in for _z = 0 to times - 1 do let loop_end = !first_n + n - 1 in for i = !first_n to loop_end do let x = n + i in Identity_table.replace tbl ~key:x ~data:x; Identity_table.remove tbl i; done; first_n := !first_n + n done; let elapsed = Time.diff (Time.now ()) start in printf "Core hashtbl took %6f\n" ((Time.Span.to_sec elapsed) /. (Float.of_int times)); printf "Size: %d\n%!" (Identity_table.length tbl); for i = !first_n to !first_n + n - 1 do assert ( (Identity_table.find_exn tbl i) = i ) done; ;; (** Benchmark Pooled_hashtbl, a linked chain hashtbl backed by a Zero.Obj_array pool *) let test_zero () = let module Identity_table = Pooled_hashtbl.Make(struct include Int let hash x = x end) in let tbl = Identity_table.create ~size:(2*n) () in for i = 0 to n - 1 do Identity_table.replace tbl ~key:i ~data:i; done; let start = Time.now () in let first_n = ref 0 in for _z = 0 to times - 1 do let loop_end = !first_n + n - 1 in for i = !first_n to loop_end do let x = n + i in Identity_table.replace tbl ~key:x ~data:x; Identity_table.remove tbl i; done; first_n := !first_n + n done; let elapsed = Time.diff (Time.now ()) start in printf "Zero pooled hashtbl took %6f\n" ((Time.Span.to_sec elapsed) /. (Float.of_int times)); printf "Size: %d\n%!" (Identity_table.length tbl); for i = !first_n to !first_n + n - 1 do assert ( (Identity_table.find_exn tbl i) = i ) done; ;; let () = for _i=0 to 3 do test_core (); test_zero (); done; ;; core_kernel-113.00.00/check_caml_modify/000077500000000000000000000000001256461164500177365ustar00rootroot00000000000000core_kernel-113.00.00/check_caml_modify/caml_modify.ml000066400000000000000000000006201256461164500225510ustar00rootroot00000000000000external count : unit -> int = "check_caml_modify_count" "noalloc" external reset : unit -> unit = "check_caml_modify_reset" "noalloc" TEST_UNIT = let x = Array.create (32 * 1024) [Random.int 10] in let v = [Random.int 10] in let n = count () in x.(0) <- v; assert (count () = n + 1); let x = Array.create (32 * 1024) 0 in let n = count () in x.(0) <- 2; assert (count () = n); ;; core_kernel-113.00.00/check_caml_modify/caml_modify.mli000066400000000000000000000007041256461164500227250ustar00rootroot00000000000000(** Increment a counter whenever [caml_modify] is called. This library wraps caml_modify at the C level, and should only be used in testing code. *) (** [count ()] returns the number of times [caml_modify] has been called since the last call to {!reset}. *) external count : unit -> int = "check_caml_modify_count" "noalloc" (** [reset ()] reset the counter to [0]. *) external reset : unit -> unit = "check_caml_modify_reset" "noalloc" core_kernel-113.00.00/check_caml_modify/caml_modify_stub.c000066400000000000000000000005441256461164500234250ustar00rootroot00000000000000#include CAMLextern void __real_caml_modify(value *fp, value v); static long count = 0; CAMLprim void __wrap_caml_modify(value *fp, value v) { count++; __real_caml_modify(fp, v); } CAMLprim value check_caml_modify_count() { return Val_long(count); } CAMLprim value check_caml_modify_reset() { count = 0; return Val_unit; } core_kernel-113.00.00/check_caml_modify/check_caml_modify.mldylib000066400000000000000000000001461256461164500247350ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 20ccccfde04b622eac57ffec7f1696f1) Check_caml_modify # OASIS_STOP core_kernel-113.00.00/check_caml_modify/check_caml_modify.mllib000066400000000000000000000001461256461164500244000ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 20ccccfde04b622eac57ffec7f1696f1) Check_caml_modify # OASIS_STOP core_kernel-113.00.00/check_caml_modify/check_caml_modify.mlpack000066400000000000000000000001401256461164500245420ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 75879b155cae771df93b868cb45df14b) Caml_modify # OASIS_STOP core_kernel-113.00.00/check_caml_modify/libcheck_caml_modify_stubs.clib000066400000000000000000000001471256461164500261220ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 19d712e186346bdc40e5eeaa37084de9) caml_modify_stub.o # OASIS_STOP core_kernel-113.00.00/config/000077500000000000000000000000001256461164500155635ustar00rootroot00000000000000core_kernel-113.00.00/config/detect.sh000077500000000000000000000006201256461164500173700ustar00rootroot00000000000000#!/bin/sh # Detect supported features and put the result in setup.data set -e if ld -lm -shared --wrap caml_modify -o /dev/null 2>/dev/null; then ld_wrap_possible=true else ld_wrap_possible=false fi if [ -e setup.data ]; then sed '/^ld_wrap_possible=/d' setup.data > setup.data.new mv setup.data.new setup.data fi cat >> setup.data <&2 exit 2 fi OCAMLC="$1" ML_OUTFILE="$2" C_OUTFILE="$3" shift 3 SRC=config/test.c OUT=config/test.out trap "rm -f $OUT" EXIT $OCAMLC -ccopt -E $OCAML_CFLAGS -c $SRC | grep '^"OUT:[^"]*"$' | sed 's/"OUT:\([^"]*\)"/\1/' | tee > $OUT OCAML_VERSION="`ocamlc -version`" case "$OCAML_VERSION" in 4.0[1-9]*|4.[1-9]*) echo "DEFINE OCAML_4" >> $OUT echo "DEFINE OCAML_4_01" >> $OUT ;; 4*) echo "DEFINE OCAML_4" >> $OUT ;; esac mv "$OUT" "$ML_OUTFILE" { sentinel="CORE_`basename "$C_OUTFILE" | tr a-z. A-Z_`" cat < "$C_OUTFILE" core_kernel-113.00.00/config/test.c000066400000000000000000000004161256461164500167070ustar00rootroot00000000000000/* This file is just preprocessed. Lines of the form "OUT:XXX" are kept and replaced by XXX in the output to produce lib/config.mlh. */ #include /* Defined in */ #if defined(ARCH_SIXTYFOUR) "OUT:DEFINE ARCH_SIXTYFOUR" #endif core_kernel-113.00.00/configure000077500000000000000000000005531256461164500162300ustar00rootroot00000000000000#!/bin/sh # OASIS_START # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) set -e FST=true for i in "$@"; do if $FST; then set -- FST=false fi case $i in --*=*) ARG=${i%%=*} VAL=${i##*=} set -- "$@" "$ARG" "$VAL" ;; *) set -- "$@" "$i" ;; esac done ocaml setup.ml -configure "$@" # OASIS_STOP core_kernel-113.00.00/example/000077500000000000000000000000001256461164500157515ustar00rootroot00000000000000core_kernel-113.00.00/example/o.ml000066400000000000000000000002171256461164500165410ustar00rootroot00000000000000open Core_kernel.Std let x = Float.O.((3. + 4.) / of_int 2) let () = if Float.O.(sqrt 3. > 4.) then printf "yo%!" else printf "gabba%!" core_kernel-113.00.00/generate/000077500000000000000000000000001256461164500161105ustar00rootroot00000000000000core_kernel-113.00.00/generate/generate_pow_overflow_bounds.ml000066400000000000000000000106051256461164500244200ustar00rootroot00000000000000(* NB: This needs to be pure OCaml (no Core!), since we need this in order to build Core. *) (* This module generates lookup tables to detect integer overflow when calculating integer exponents. At index [e], [table.[e]^e] will not overflow, but [(table[e] + 1)^e] will. *) module Big_int = struct include Big_int type t = big_int let (>) = gt_big_int let (<=) = le_big_int let (^) = power_big_int_positive_int let (-) = sub_big_int let (+) = add_big_int let one = unit_big_int let sqrt = sqrt_big_int let to_string = string_of_big_int end module Array = StdLabels.Array type generated_type = | Int31 | Int32 | Int63 | Int64 type type_info = { format_entry : Big_int.t -> string; max_val : Big_int.t; ocaml_type : string; generate_negative_bounds : bool; (* [maybe_32bit=true] means that we should check at runtime the size of integers (num_bits) - it might be 32bit (i.e., JavaScript) instead of 63bit or 31bit. This only applies to Int31 and Int63. *) maybe_32bit : bool } let max_big_int_for_bits bits = let shift = bits - 1 in (* sign bit *) Big_int.((shift_left_big_int one shift) - one) ;; let type_info_of_type = let type_info_for_ocaml_int max_val = let safe_to_print = let int31_max = max_big_int_for_bits 31 in fun x -> Big_int.(x <= int31_max) in let format_entry b = if safe_to_print b then Big_int.to_string b else Printf.sprintf "Int64.to_int %sL" (Big_int.to_string b) in { format_entry; max_val; ocaml_type = "int"; generate_negative_bounds = false; maybe_32bit = true } in function | Int31 -> type_info_for_ocaml_int (max_big_int_for_bits 31) | Int63 -> type_info_for_ocaml_int (max_big_int_for_bits 63) | Int32 -> { format_entry = (fun b -> Big_int.to_string b ^ "l"); max_val = max_big_int_for_bits 32; ocaml_type = "int32"; generate_negative_bounds = false; maybe_32bit = false; } | Int64 -> { format_entry = (fun b -> Big_int.to_string b ^ "L"); max_val = max_big_int_for_bits 64; ocaml_type = "int64"; generate_negative_bounds = true; maybe_32bit = false; } ;; let highest_base exponent max_val = let open Big_int in match exponent with | 0 | 1 -> max_val | 2 -> sqrt max_val | _ -> let rec search possible_base = if possible_base ^ exponent > max_val then begin let res = possible_base - one in assert (res ^ exponent <= max_val); res end else search (possible_base + one) in search one ;; let info32 = type_info_of_type Int32 let maybe_32bit info convert make_name = if info.maybe_32bit then Printf.sprintf "\n if Int_conversions.num_bits_int = 32 then\n %s %s\n else\n " convert (make_name info32) else "\n " let print_array ~info ~descr arr = let name info = Printf.sprintf "%s_%s_overflow_bounds" info.ocaml_type descr in Printf.printf "let %s : %s array =%s[|\n" (name info) info.ocaml_type (maybe_32bit info "Array.map Int32.to_int" name); let spaces = if info.maybe_32bit then String.make 6 ' ' else String.make 4 ' ' in Array.iter arr ~f:(fun b -> Printf.printf "%s%s;\n" spaces (info.format_entry b)); Printf.printf " |]\n\n"; ;; let gen_bounds ocaml_type = let info = type_info_of_type ocaml_type in let name info = Printf.sprintf "overflow_bound_max_%s_value" info.ocaml_type in Printf.printf "let %s : %s =%s%s\n\n" (name info) info.ocaml_type (maybe_32bit info "Int32.to_int" name) (info.format_entry info.max_val); let pos_bounds = Array.init 64 ~f:(fun i -> highest_base i info.max_val) in print_array ~info ~descr:"positive" pos_bounds; if info.generate_negative_bounds then begin let neg_bounds = Array.map pos_bounds ~f:Big_int.minus_big_int in print_array ~info ~descr:"negative" neg_bounds; end; ;; let () = Printf.printf "(* This file was autogenerated by %s *)\n\n" Sys.argv.(0); Printf.printf "(* We have to use Int64.to_int_exn instead of int constants to make\n"; Printf.printf " sure that file can be preprocessed on 32-bit machines. *)\n\n"; Printf.printf "INCLUDE \"config.mlh\"\n\n"; gen_bounds Int32; Printf.printf "IFDEF ARCH_SIXTYFOUR THEN\n\n"; gen_bounds Int63; Printf.printf "ELSE\n\n"; gen_bounds Int31; Printf.printf "END\n\n"; gen_bounds Int64; ;; core_kernel-113.00.00/myocamlbuild.ml000066400000000000000000000444221256461164500173370ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 293325619b977003dbabc19faaed3968) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end # 132 "myocamlbuild.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 237 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin type conf = { no_automatic_syntax: bool; } (* these functions are not really officially exported *) let run_and_read = Ocamlbuild_pack.My_unix.run_and_read let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings let exec_from_conf exec = let exec = let env_filename = Pathname.basename BaseEnvLight.default_filename in let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in try BaseEnvLight.var_get exec env with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" exec; exec in let fix_win32 str = if Sys.os_type = "Win32" then begin let buff = Buffer.create (String.length str) in (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. *) String.iter (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) str; Buffer.contents buff end else begin str end in fix_win32 exec let split s ch = let buf = Buffer.create 13 in let x = ref [] in let flush () = x := (Buffer.contents buf) :: !x; Buffer.clear buf in String.iter (fun c -> if c = ch then flush () else Buffer.add_char buf c) s; flush (); List.rev !x let split_nl s = split s '\n' let before_space s = try String.before s (String.index s ' ') with Not_found -> s (* ocamlfind command *) let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] let well_known_syntax = [ "camlp4.quotations.o"; "camlp4.quotations.r"; "camlp4.exceptiontracer"; "camlp4.extend"; "camlp4.foldgenerator"; "camlp4.listcomprehension"; "camlp4.locationstripper"; "camlp4.macro"; "camlp4.mapgenerator"; "camlp4.metagenerator"; "camlp4.profiler"; "camlp4.tracer" ] let dispatch conf = function | After_options -> (* By using Before_options one let command line options have an higher * priority on the contrary using After_options will guarantee to have * the higher priority override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; Options.ocamlmktop := ocamlfind & A"ocamlmktop"; Options.ocamlmklib := ocamlfind & A"ocamlmklib" | After_rules -> (* When one link an OCaml library/binary/package, one should use * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; if not (conf.no_automatic_syntax) then begin (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) List.iter begin fun pkg -> let base_args = [A"-package"; A pkg] in (* TODO: consider how to really choose camlp4o or camlp4r. *) let syn_args = [A"-syntax"; A "camlp4o"] in let (args, pargs) = (* Heuristic to identify syntax extensions: whether they end in ".syntax"; some might not. *) if Filename.check_suffix pkg "syntax" || List.mem pkg well_known_syntax then (syn_args @ base_args, syn_args) else (base_args, []) in flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; (* TODO: Check if this is allowed for OCaml < 3.12.1 *) flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; end (find_packages ()); end; (* Like -package but for extensions syntax. Morover -syntax is useless * when linking. *) List.iter begin fun syntax -> flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); | _ -> () end module MyOCamlbuildBase = struct (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall *) open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler type dir = string type file = string type name = string type tag = string (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) type t = { lib_ocaml: (name * dir list * string list) list; lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) includes: (dir * dir list) list; } let env_filename = Pathname.basename BaseEnvLight.default_filename let dispatch_combine lst = fun e -> List.iter (fun dispatch -> dispatch e) lst let tag_libstubs nm = "use_lib"^nm^"_stubs" let nm_libstubs nm = nm^"_stubs" let dispatch t e = let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then String.sub s 1 ((String.length s) - 1) else s in List.iter (fun (opt, var) -> try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s\n" var) [ Options.ext_obj, "ext_obj"; Options.ext_lib, "ext_lib"; Options.ext_dll, "ext_dll"; ] | After_rules -> (* Declare OCaml libraries *) List.iter (function | nm, [], intf_modules -> ocaml_lib nm; let cmis = List.map (fun m -> (String.uncapitalize m) ^ ".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis | nm, dir :: tl, intf_modules -> ocaml_lib ~dir:dir (dir^"/"^nm); List.iter (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) tl; let cmis = List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") intf_modules in dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] cmis) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; (* Declare C libraries *) List.iter (fun (lib, dir, headers) -> (* Handle C part of library *) flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); (* When ocaml link something that use the C library, then one need that file to be up to date. This holds both for programs and for libraries. *) dep ["link"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; dep ["compile"; "ocaml"; tag_libstubs lib] [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) dep ["compile"; "c"] headers; (* Setup search path for lib *) flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; (* Add flags *) List.iter (fun (tags, cond_specs) -> let spec = BaseEnvLight.var_choose cond_specs env in let rec eval_specs = function | S lst -> S (List.map eval_specs lst) | A str -> A (BaseEnvLight.var_expand str env) | spec -> spec in flag tags & (eval_specs spec)) t.flags | _ -> () let dispatch_default conf t = dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch conf; ] end # 606 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [ ("core_kernel", ["src"], []); ("check_caml_modify", ["check_caml_modify"], []) ]; lib_c = [ ("core_kernel", "src", [ "src/config.h"; "src/core_params.h"; "src/core_bigstring.h"; "src/ocaml_utils.h"; "src/jane_common.h"; "src/time_ns_stubs.h" ]); ("check_caml_modify", "check_caml_modify", []) ]; flags = []; includes = [("test", ["check_caml_modify"; "src"])] } ;; let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; # 639 "myocamlbuild.ml" (* OASIS_STOP *) let dispatch = function | After_rules -> pflag ["compile"; "ocaml"] "I" (fun x -> S [A "-I"; A x]); dep ["ocaml"; "ocamldep"; "mlh"] ["src/config.mlh"]; flag ["mlh"; "ocaml"; "ocamldep"] (S[A"-ppopt"; A"-Isrc/"]); flag ["mlh"; "ocaml"; "compile"] (S[A"-ppopt"; A"-Isrc/"]); flag ["mlh"; "ocaml"; "doc"] (S[A"-ppopt"; A"-Isrc/"]); flag ["ocaml"; "link"; "native"; "caml_modify_wrapper"] (S [A "-cclib"; A "-Xlinker"; A "-cclib"; A "--wrap"; A "-cclib"; A "-Xlinker"; A "-cclib"; A "caml_modify"]); flag ["ocaml"; "native"; "compile"; "inline0"] (S[A"-inline"; A"0"]); List.iter (fun tag -> pflag ["ocaml"; tag] "pa_ounit_lib" (fun s -> S[A"-ppopt"; A"-pa-ounit-lib"; A"-ppopt"; A s])) ["ocamldep"; "compile"; "doc"]; | _ -> () let () = Ocamlbuild_plugin.dispatch (fun hook -> dispatch hook; dispatch_default hook) core_kernel-113.00.00/setup.ml000066400000000000000000006015421256461164500160200ustar00rootroot00000000000000(* OASIS_START *) (* DO NOT EDIT (digest: 7fd76dd93c86e35b7ca70ef88a0c2965) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISContext = struct (* # 22 "src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", (* TODO: remove this chdir. *) Arg.String (fun str -> Sys.chdir str), s_ "dir Change directory before running."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct (* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf end module OASISUtils = struct (* # 22 "src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = Hashtbl.hash (String.lowercase s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in String.lowercase buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 22 "src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 78 "src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then String.lowercase else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "src/oasis/OASISVersion.ml" *) open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let version_compare_string s1 s2 = version_compare (version_of_string s1) (version_of_string s2) let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) let rec comparator_ge v' = let cmp v = version_compare v v' >= 0 in function | VEqual v | VGreaterEqual v | VGreater v -> cmp v | VLesserEqual _ | VLesser _ -> false | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end module OASISLicense = struct (* # 22 "src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISText = struct (* # 22 "src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISTypes = struct (* # 22 "src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string type host_dirname = string type host_filename = string type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list (* # 115 "src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename | DocText | PDF | PostScript | Info of unix_filename | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; copyrights: string list; maintainers: string list; authors: string list; homepage: url option; synopsis: string; description: OASISText.t option; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; sections: section list; plugins: [`Extra] plugin list; disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version t.oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" t.name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem t.name features in if not has_feature then match origin with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some str -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "It compiles the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") end module OASISUnixPath = struct (* # 22 "src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) end module OASISHostPath = struct (* # 22 "src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 22 "src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 22 "src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists bs modul with | `Sources (base_fn, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map begin List.fold_left begin fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu end [] end (find_modules lib.lib_modules "cmi") in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name; acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name ; lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2998 "setup.ml" module BaseContext = struct (* # 22 "src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name, value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = OASISHostPath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct (* # 22 "src/base/BaseLog.ml" *) open OASISUtils let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) let load () = if Sys.file_exists default_filename then begin let chn = open_in default_filename in let scbuf = Scanf.Scanning.from_file default_filename in let rec read_aux (st, lst) = if not (Scanf.Scanning.end_of_input scbuf) then begin let acc = try Scanf.bscanf scbuf "%S %S\n" (fun e d -> let t = e, d in if SetTupleString.mem t st then st, lst else SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> failwith (Scanf.bscanf scbuf "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" default_filename line)) in read_aux acc end else begin close_in chn; List.rev lst end in read_aux (SetTupleString.empty, []) end else begin [] end let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename in Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out let unregister event data = if Sys.file_exists default_filename then begin let lst = load () in let chn_out = open_out default_filename in let write_something = ref false in List.iter (fun (e, d) -> if e <> event || d <> data then begin write_something := true; Printf.fprintf chn_out "%S %S\n" e d end) lst; close_out chn_out; if not !write_something then Sys.remove default_filename end let filter events = let st_events = List.fold_left (fun st e -> SetString.add e st) SetString.empty events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) let exists event data = List.exists (fun v -> (event, data) = v) (load ()) end module BaseBuilt = struct (* # 22 "src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test t args = BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init t.package; if not !rno_doc then begin info "Running doc step"; doc t [||]; end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test t [||] end else begin info "Skipping test step" end let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args let reinstall t args = uninstall t args; install t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, doc)) args | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 5409 "setup.ml" module InternalConfigurePlugin = struct (* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) (** Configure using internal scheme @author Sylvain Le Gall *) open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = let var_ignore_eval var = let _s: string = var () in () in let errors = ref SetString.empty in let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf (fun b -> errors := SetString.add (Buffer.contents b) !errors; Buffer.clear b) buff fmt in let warn_exception e = warning "%s" (Printexc.to_string e) in (* Check tools *) let check_tools lst = List.iter (function | ExternalTool tool -> begin try var_ignore_eval (BaseCheck.prog tool) with e -> warn_exception e; add_errors (f_ "Cannot find external tool '%s'") tool end | InternalExecutable nm1 -> (* Check that matching tool is built *) List.iter (function | Executable ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal executable \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) lst in let build_checks sct bs = if var_choose bs.bs_build then begin if bs.bs_compiled_object = Native then begin try var_ignore_eval BaseStandardVar.ocamlopt with e -> warn_exception e; add_errors (f_ "Section %s requires native compilation") (OASISSection.string_of_section sct) end; (* Check tools *) check_tools bs.bs_build_tools; (* Check depends *) List.iter (function | FindlibPackage (findlib_pkg, version_comparator) -> begin try var_ignore_eval (BaseCheck.package ?version_comparator findlib_pkg) with e -> warn_exception e; match version_comparator with | None -> add_errors (f_ "Cannot find findlib package %s") findlib_pkg | Some ver_cmp -> add_errors (f_ "Cannot find findlib package %s (%s)") findlib_pkg (OASISVersion.string_of_comparator ver_cmp) end | InternalLibrary nm1 -> (* Check that matching library is built *) List.iter (function | Library ({cs_name = nm2}, {bs_build = build}, _) when nm1 = nm2 -> if not (var_choose build) then add_errors (f_ "Cannot find buildable internal library \ '%s' when checking build depends") nm1 | _ -> ()) pkg.sections) bs.bs_build_depends end in (* Parse command line *) BaseArgExt.parse argv (BaseEnv.args ()); (* OCaml version *) begin match pkg.ocaml_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "ocaml" ver_cmp BaseStandardVar.ocaml_version) with e -> warn_exception e; add_errors (f_ "OCaml version %s doesn't match version constraint %s") (BaseStandardVar.ocaml_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Findlib version *) begin match pkg.findlib_version with | Some ver_cmp -> begin try var_ignore_eval (BaseCheck.version "findlib" ver_cmp BaseStandardVar.findlib_version) with e -> warn_exception e; add_errors (f_ "Findlib version %s doesn't match version constraint %s") (BaseStandardVar.findlib_version ()) (OASISVersion.string_of_comparator ver_cmp) end | None -> () end; (* Make sure the findlib version is fine for the OCaml compiler. *) begin let ocaml_ge4 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) (OASISVersion.version_of_string "4.0.0") >= 0 in if ocaml_ge4 then let findlib_lt132 = OASISVersion.version_compare (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) (OASISVersion.version_of_string "1.3.2") < 0 in if findlib_lt132 then add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || BaseStandardVar.os_type () = "Cygwin" then begin try var_ignore_eval BaseStandardVar.flexlink with e -> warn_exception e; add_errors (f_ "Cannot find 'flexlink'") end; (* Check build depends *) List.iter (function | Executable (_, bs, _) | Library (_, bs, _) as sct -> build_checks sct bs | Doc (_, doc) -> if var_choose doc.doc_build then check_tools doc.doc_build_tools | Test (_, test) -> if var_choose test.test_run then check_tools test.test_tools | _ -> ()) pkg.sections; (* Check if we need native dynlink (presence of libraries that compile to * native) *) begin let has_cmxa = List.exists (function | Library (_, bs, _) -> var_choose bs.bs_build && (bs.bs_compiled_object = Native || (bs.bs_compiled_object = Best && bool_of_string (BaseStandardVar.is_native ()))) | _ -> false) pkg.sections in if has_cmxa then var_ignore_eval BaseStandardVar.native_dynlink end; (* Check errors *) if SetString.empty != !errors then begin List.iter (fun e -> error "%s" e) (SetString.elements !errors); failwithf (fn_ "%d configuration error" "%d configuration errors" (SetString.cardinal !errors)) (SetString.cardinal !errors) end end module InternalInstallPlugin = struct (* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) (** Install using internal scheme @author Sylvain Le Gall *) open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes open OASISFindlib open OASISGettext open OASISUtils let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) let obj_hook = ref (fun (cs, bs, obj) -> cs, bs, obj, []) let doc_hook = ref (fun (cs, doc) -> cs, doc) let install_file_ev = "install-file" let install_dir_ev = "install-dir" let install_findlib_ev = "install-findlib" let win32_max_command_line_length = 8000 let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) let first_args = ["install"; findlib_name; meta] in (* Arguments for remaining commands: *) let other_args = ["install"; findlib_name; "-add"] in (* Extract as much files as possible from [files], [len] is the current command line length: *) let rec get_files len acc files = match files with | [] -> (List.rev acc, []) | file :: rest -> let len = len + 1 + String.length file in if len > win32_max_command_line_length then (List.rev acc, files) else get_files len (file :: acc) rest in (* Split the command into several commands. *) let rec split args files = match files with | [] -> [] | _ -> (* Length of "ocamlfind install [META|-add]" *) let len = List.fold_left (fun len arg -> len + 1 (* for the space *) + String.length arg) (String.length ocamlfind) args in match get_files len [] files with | ([], _) -> failwith (s_ "Command line too long.") | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) let () = let findlib_ge_132 = OASISVersion.comparator_apply (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf (f_ "Installing the library %s require to use the \ flag '-add' of ocamlfind because the command \ line is too long. This flag is only available \ for findlib 1.3.2. Please upgrade findlib from \ %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in cmd :: cmds in (* The first command does not use -add: *) split first_args files else ["install" :: findlib_name :: meta :: files] let install pkg argv = let in_destdir = try let destdir = destdir () in (* Practically speaking destdir is prepended * at the beginning of the target filename *) fun fn -> destdir^fn with PropList.Not_set _ -> fun fn -> fn in let install_file ?tgt_fn src_file envdir = let tgt_dir = in_destdir (envdir ()) in let tgt_file = Filename.concat tgt_dir (match tgt_fn with | Some fn -> fn | None -> Filename.basename src_file) in (* Create target directory if needed *) OASISFileUtil.mkdir_parent ~ctxt:!BaseContext.default (fun dn -> info (f_ "Creating directory '%s'") dn; BaseLog.register install_dir_ev dn) tgt_dir; (* Really install files *) info (f_ "Copying file '%s' to '%s'") src_file tgt_file; OASISFileUtil.cp ~ctxt:!BaseContext.default src_file tgt_file; BaseLog.register install_file_ev tgt_file in (* Install data into defined directory *) let install_data srcdir lst tgtdir = let tgtdir = OASISHostPath.of_unix (var_expand tgtdir) in List.iter (fun (src, tgt_opt) -> let real_srcs = OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat srcdir src) in if real_srcs = [] then failwithf (f_ "Wildcard '%s' doesn't match any files") src; List.iter (fun fn -> install_file fn (fun () -> match tgt_opt with | Some s -> OASISHostPath.of_unix (var_expand s) | None -> tgtdir)) real_srcs) lst in let make_fnames modul sufx = List.fold_right begin fun sufx accu -> (String.capitalize modul ^ sufx) :: (String.uncapitalize modul ^ sufx) :: accu end sufx [] in (** Install all libraries *) let install_libs pkg = let files_of_library (f_data, acc) data_lib = let cs, bs, lib, lib_extra = !lib_hook data_lib in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BLib cs.cs_name then begin let acc = (* Start with acc + lib_extra *) List.rev_append lib_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in library %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc lib.lib_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BLib cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the library *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end and files_of_object (f_data, acc) data_obj = let cs, bs, obj, obj_extra = !obj_hook data_obj in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then begin let acc = (* Start with acc + obj_extra *) List.rev_append obj_extra acc in let acc = (* Add uncompiled header from the source tree *) let path = OASISHostPath.of_unix bs.bs_path in List.fold_left begin fun acc modul -> begin try [List.find OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".mli"; ".ml"]))] with Not_found -> warning (f_ "Cannot find source header for module %s \ in object %s") modul cs.cs_name; [] end @ List.filter OASISFileUtil.file_exists_case (List.map (Filename.concat path) (make_fnames modul [".annot";".cmti";".cmt"])) @ acc end acc obj.obj_modules in let acc = (* Get generated files *) BaseBuilt.fold BaseBuilt.BObj cs.cs_name (fun acc fn -> fn :: acc) acc in let f_data () = (* Install data associated with the object *) install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name); f_data () in (f_data, acc) end else begin (f_data, acc) end in (* Install one group of library *) let install_group_lib grp = (* Iterate through all group nodes *) let rec install_group_lib_aux data_and_files grp = let data_and_files, children = match grp with | Container (_, children) -> data_and_files, children | Package (_, cs, bs, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children | Package (_, cs, bs, `Object obj, children) -> files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux data_and_files children in (* Findlib name of the root library *) let findlib_name = findlib_of_group grp in (* Determine root library *) let root_lib = root_of_group grp in (* All files to install for this library *) let f_data, files = install_group_lib_aux (ignore, []) grp in (* Really install, if there is something to install *) if files = [] then begin warning (f_ "Nothing to install for findlib library '%s'") findlib_name end else begin let meta = (* Search META file *) let _, bs, _ = root_lib in let res = Filename.concat bs.bs_path "META" in if not (OASISFileUtil.file_exists_case res) then failwithf (f_ "Cannot find file '%s' for findlib library %s") res findlib_name; res in let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) let remove_prefix p n = let plen = String.length p in let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + (if plen < nlen && n.[plen] = fn_sep then 1 else 0) in String.sub n cutpoint (nlen - cutpoint) end else n in List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") findlib_name; let ocamlfind = ocamlfind () in let commands = split_install_command ocamlfind findlib_name meta files in List.iter (OASISExec.run ~ctxt:!BaseContext.default ocamlfind) commands; BaseLog.register install_findlib_ev findlib_name end; (* Install data files *) f_data (); in let group_libs, _, _ = findlib_mapping pkg in (* We install libraries in groups *) List.iter install_group_lib group_libs in let install_execs pkg = let install_exec data_exec = let cs, bs, exec = !exec_hook data_exec in if var_choose bs.bs_install && BaseBuilt.is_built BaseBuilt.BExec cs.cs_name then begin let exec_libdir () = Filename.concat (libdir ()) pkg.name in BaseBuilt.fold BaseBuilt.BExec cs.cs_name (fun () fn -> install_file ~tgt_fn:(cs.cs_name ^ ext_program ()) fn bindir) (); BaseBuilt.fold BaseBuilt.BExecLib cs.cs_name (fun () fn -> install_file fn exec_libdir) (); install_data bs.bs_path bs.bs_data_files (Filename.concat (datarootdir ()) pkg.name) end in List.iter (function | Executable (cs, bs, exec)-> install_exec (cs, bs, exec) | _ -> ()) pkg.sections in let install_docs pkg = let install_doc data = let cs, doc = !doc_hook data in if var_choose doc.doc_install && BaseBuilt.is_built BaseBuilt.BDoc cs.cs_name then begin let tgt_dir = OASISHostPath.of_unix (var_expand doc.doc_install_dir) in BaseBuilt.fold BaseBuilt.BDoc cs.cs_name (fun () fn -> install_file fn (fun () -> tgt_dir)) (); install_data Filename.current_dir_name doc.doc_data_files doc.doc_install_dir end in List.iter (function | Doc (cs, doc) -> install_doc (cs, doc) | _ -> ()) pkg.sections in install_libs pkg; install_execs pkg; install_docs pkg (* Uninstall already installed data *) let uninstall _ argv = List.iter (fun (ev, data) -> if ev = install_file_ev then begin if OASISFileUtil.file_exists_case data then begin info (f_ "Removing file '%s'") data; Sys.remove data end else begin warning (f_ "File '%s' doesn't exist anymore") data end end else if ev = install_dir_ev then begin if Sys.file_exists data && Sys.is_directory data then begin if Sys.readdir data = [||] then begin info (f_ "Removing directory '%s'") data; OASISFileUtil.rmdir ~ctxt:!BaseContext.default data end else begin warning (f_ "Directory '%s' is not empty (%s)") data (String.concat ", " (Array.to_list (Sys.readdir data))) end end else begin warning (f_ "Directory '%s' doesn't exist anymore") data end end else if ev = install_findlib_ev then begin info (f_ "Removing findlib library '%s'") data; OASISExec.run ~ctxt:!BaseContext.default (ocamlfind ()) ["remove"; data] end else failwithf (f_ "Unknown log event '%s'") ev; BaseLog.unregister ev data) (* We process event in reverse order *) (List.rev (BaseLog.filter [install_file_ev; install_dir_ev; install_findlib_ev])) end # 6273 "setup.ml" module OCamlbuildCommon = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) (** Functions common to OCamlbuild build and doc plugin *) open OASISGettext open BaseEnv open BaseStandardVar open OASISTypes type extra_args = string list let ocamlbuild_clean_ev = "ocamlbuild-clean" let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten [ if (os_type ()) = "Win32" then [ "-classic-display"; "-no-log"; "-no-links"; "-install-lib-dir"; (Filename.concat (standard_library ()) "ocamlbuild") ] else []; if not (bool_of_string (is_native ())) || (os_type ()) = "Win32" then [ "-byte-plugin" ] else []; args; if bool_of_string (debug ()) then ["-tag"; "debug"] else []; if bool_of_string (tests ()) then ["-tag"; "tests"] else []; if bool_of_string (profile ()) then ["-tag"; "profile"] else []; OASISString.nsplit (ocamlbuildflags ()) ' '; Array.to_list extra_argv; ] (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = String.concat " " (Array.to_list extra_argv) in (* Run if never called with these args *) if not (BaseLog.exists ocamlbuild_clean_ev extra_cli) then begin OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args ["-clean"] extra_argv); BaseLog.register ocamlbuild_clean_ev extra_cli; at_exit (fun () -> try BaseLog.unregister ocamlbuild_clean_ev extra_cli with _ -> ()) end (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html *) OASISExec.run ~ctxt:!BaseContext.default (ocamlbuild ()) (fix_args args extra_argv); (* Remove any clean event, we must run it again *) List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = function | "-build-dir" :: dir :: tl -> search_args dir tl | _ :: tl -> search_args dir tl | [] -> dir in search_args "_build" (fix_args [] extra_argv) end module OCamlbuildPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) (** Build using ocamlbuild @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISUtils open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage let cond_targets_hook = ref (fun lst -> lst) let build extra_args pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat (build_dir argv) fn in (* Return the unix filename in host build directory *) let in_build_dir_of_unix fn = in_build_dir (OASISHostPath.of_unix fn) in let cond_targets = List.fold_left (fun acc -> function | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_library in_build_dir_of_unix (cs, bs, lib) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ~what:".cma" fn || ends_with ~what:".cmxs" fn || ends_with ~what:".cmxa" fn || ends_with ~what:(ext_lib ()) fn || ends_with ~what:(ext_dll ()) fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for library %s") cs.cs_name end | Object (cs, bs, obj) when var_choose bs.bs_build -> begin let evs, unix_files = BaseBuilt.of_object in_build_dir_of_unix (cs, bs, obj) in let tgts = List.flatten (List.filter (fun l -> l <> []) (List.map (List.filter (fun fn -> ends_with ".cmo" fn || ends_with ".cmx" fn)) unix_files)) in match tgts with | _ :: _ -> (evs, tgts) :: acc | [] -> failwithf (f_ "No possible ocamlbuild targets for object %s") cs.cs_name end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, unix_exec_is, unix_dll_opt = BaseBuilt.of_executable in_build_dir_of_unix (cs, bs, exec) in let target ext = let unix_tgt = (OASISUnixPath.concat bs.bs_path (OASISUnixPath.chop_extension exec.exec_main_is))^ext in let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs in evs, [unix_tgt] in (* Add executable *) let acc = match bs.bs_compiled_object with | Native -> (target ".native") :: acc | Best when bool_of_string (is_native ()) -> (target ".native") :: acc | Byte | Best -> (target ".byte") :: acc in acc end | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] (* Keep the pkg.sections ordered *) (List.rev pkg.sections); in (* Check and register built files *) let check_and_register (bt, bnm, lst) = List.iter (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf (fn_ "Expected built file %s doesn't exist." "None of expected built files %s exists." (List.length fns)) (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in (* Run the hook *) let cond_targets = !cond_targets_hook cond_targets in (* Run a list of target... *) run_ocamlbuild (List.flatten (List.map snd cond_targets) @ extra_args) argv; (* ... and register events *) List.iter check_and_register (List.flatten (List.map fst cond_targets)) let clean pkg extra_args = run_clean extra_args; List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections end module OCamlbuildDocPlugin = struct (* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) open OASISTypes open OASISGettext open OASISMessage open OCamlbuildCommon open BaseStandardVar type run_t = { extra_args: string list; run_path: unix_filename; } let doc_build run pkg (cs, doc) argv = let index_html = OASISUnixPath.make [ run.run_path; cs.cs_name^".docdir"; "index.html"; ] in let tgt_dir = OASISHostPath.make [ build_dir argv; OASISHostPath.of_unix run.run_path; cs.cs_name^".docdir"; ] in run_ocamlbuild (index_html :: run.extra_args) argv; List.iter (fun glb -> BaseBuilt.register BaseBuilt.BDoc cs.cs_name [OASISFileUtil.glob ~ctxt:!BaseContext.default (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] let doc_clean run pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name end # 6651 "setup.ml" module CustomPlugin = struct (* # 22 "src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean t pkg extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) evs) pkg.sections let clean t pkg extra_args = clean t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean t pkg extra_args = distclean t pkg extra_args end module Test = struct let main t pkg (cs, test) extra_args = try main t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean t pkg (cs, test) extra_args = clean t pkg extra_args let distclean t pkg (cs, test) extra_args = distclean t pkg extra_args end module Doc = struct let main t pkg (cs, _) extra_args = main t pkg extra_args; BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] let clean t pkg (cs, _) extra_args = clean t pkg extra_args; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name let distclean t pkg (cs, _) extra_args = distclean t pkg extra_args end end # 6799 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; build = OCamlbuildPlugin.build ["-use-ocamlfind"]; test = [ ("test_pool_caml_modify_check", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$pool_caml_modify_check", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; doc = []; install = InternalInstallPlugin.install; uninstall = InternalInstallPlugin.uninstall; clean = [OCamlbuildPlugin.clean]; clean_test = [ ("test_pool_caml_modify_check", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$pool_caml_modify_check", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; clean_doc = []; distclean = []; distclean_test = [ ("test_pool_caml_modify_check", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$pool_caml_modify_check", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }) ]; distclean_doc = []; package = { oasis_version = "0.3"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.1"); findlib_version = Some (OASISVersion.VGreaterEqual "1.3.2"); alpha_features = []; beta_features = []; name = "core_kernel"; version = "113.00.00"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { OASISLicense.license = "Apache"; excption = None; version = OASISLicense.Version "2.0" }); license_file = Some "LICENSE.txt"; copyrights = [ "(C) 2008-2013 Jane Street Group LLC " ]; maintainers = ["Jane Street Group"; "LLC "]; authors = ["Jane Street Group"; "LLC "]; homepage = Some "https://github.com/janestreet/core_kernel"; synopsis = "Jane Street Capital's standard library overlay"; description = Some [ OASISText.Para "The Core suite of libraries is an industrial strength alternative to OCaml's standard library that was developed by Jane Street, the largest industrial user of OCaml." ]; categories = []; conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, Some (("config/detect.sh", [])))]; post_command = [ (OASISExpr.EBool true, Some (("config/discover.sh", ["$ocamlc"; "src/config.mlh"; "src/config.h"]))) ] }; build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "internal", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [ (OASISExpr.EBool true, Some (("$rm", ["src/config.mlh"; "src/config.h"]))) ]; post_command = [(OASISExpr.EBool true, None)] }; files_ab = []; sections = [ Flag ({ cs_name = "caml_modify_test"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "Enable caml modify tests"; flag_default = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "ld_wrap_possible", true) ] }); Library ({ cs_name = "core_kernel"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("bigarray", None); FindlibPackage ("bin_prot", None); FindlibPackage ("bin_prot.syntax", None); FindlibPackage ("comparelib.syntax", None); FindlibPackage ("custom_printf", None); FindlibPackage ("custom_printf.syntax", None); FindlibPackage ("enumerate", None); FindlibPackage ("enumerate.syntax", None); FindlibPackage ("fieldslib", None); FindlibPackage ("fieldslib.syntax", None); FindlibPackage ("herelib", None); FindlibPackage ("herelib.syntax", None); FindlibPackage ("pa_bench", None); FindlibPackage ("pa_bench.syntax", None); FindlibPackage ("pa_test", None); FindlibPackage ("pa_test.syntax", None); FindlibPackage ("pa_ounit", None); FindlibPackage ("pa_ounit.syntax", None); FindlibPackage ("pa_pipebang", None); FindlibPackage ("sexplib", None); FindlibPackage ("sexplib.syntax", None); FindlibPackage ("typerep_lib", None); FindlibPackage ("typerep_lib.syntax", None); FindlibPackage ("unix", None); FindlibPackage ("variantslib", None); FindlibPackage ("variantslib.syntax", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = [ "bigstring_marshal_stubs.c"; "bigstring_stubs.c"; "core_array_stubs.c"; "core_gc_stubs.c"; "hash_stubs.c"; "heap_block_stubs.c"; "config.h"; "core_params.h"; "exn_stubs.c"; "int_math_stubs.c"; "core_bigstring.h"; "ocaml_utils.h"; "jane_common.h"; "time_ns_stubs.c"; "time_ns_stubs.h" ]; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = [ "Applicative"; "Applicative_intf"; "Array_permute"; "Avltree"; "Backtrace"; "Bag"; "Bigbuffer_internal"; "Bigbuffer"; "Bigstring_marshal"; "Bigstring"; "Bigsubstring"; "Binable0"; "Binable"; "Binary_packing"; "Binary_searchable"; "Binary_searchable_intf"; "Blang"; "Blit"; "Blit_intf"; "Bool"; "Bounded_int_table"; "Bucket"; "Byte_units"; "Caml"; "Common"; "Commutative_group"; "Comparable_intf"; "Comparable"; "Comparator"; "Constrained_float"; "Container"; "Container_intf"; "Container_unit_tests"; "Core_arg"; "Core_array"; "Core_bin_prot"; "Core_bytes"; "Core_char"; "Core_field"; "Core_gc"; "Core_gc_unit_tests"; "Core_hashtbl_intf"; "Core_hashtbl"; "Core_int32"; "Core_int63"; "Core_int64"; "Core_int"; "Core_lazy"; "Core_list"; "Core_list_unit_tests"; "Core_map_intf"; "Core_map"; "Core_map_bench"; "Core_map_unit_tests"; "Core_nativeint"; "Core_printexc"; "Core_printf"; "Core_queue"; "Core_queue_debug"; "Core_queue_unit_tests"; "Core_random"; "Core_set_intf"; "Core_set"; "Core_set_unit_tests"; "Core_sexp"; "Core_stack"; "Core_string"; "Core_weak"; "Day_of_week"; "Debug"; "Decimal"; "Deque"; "Dequeue"; "Doubly_linked"; "Either"; "Either_intf"; "Equal"; "Error"; "Exn"; "Fdeque"; "Fheap"; "Flags_intf"; "Flags"; "Flat_array"; "Flat_array_debug"; "Flat_array_unit_tests"; "Flat_queue"; "Flat_queue_debug"; "Flat_queue_unit_tests"; "Floatable"; "Float_intf"; "Float"; "Float_robust_compare"; "Fn"; "Force_once"; "Fqueue"; "Hashable"; "Hash_heap"; "Hash_queue"; "Hash_set_intf"; "Hash_set"; "Hashtbl_unit_tests"; "Heap_block"; "Heap_intf"; "Heap"; "Hex_lexer"; "Host_and_port"; "Identifiable"; "In_channel"; "Info"; "Info_unit_tests"; "Intable"; "Int_conversions"; "Interfaces"; "Int_intf"; "Int_math"; "Int_pow2"; "Int_replace_polymorphic_compare"; "Int_set"; "Invariant"; "Invariant_intf"; "Linked_queue"; "Linked_stack"; "Make_substring"; "Memo"; "Monad"; "Monad_intf"; "Month"; "Never_returns"; "No_polymorphic_compare"; "Nothing0"; "Nothing"; "Obj_array"; "Only_in_test"; "Option"; "Ordered_collection_common"; "Ordering"; "Or_error"; "Out_channel"; "Percent"; "Perms"; "Pid"; "Poly"; "Polymorphic_compare_intf"; "Polymorphic_compare"; "Pool"; "Pool_intf"; "Pool_unit_tests"; "Pooled_hashtbl"; "Pooled_hashtbl_unit_test"; "Pow_overflow_bounds"; "Pretty_printer"; "Quickcheck"; "Quickcheck_generator"; "Quickcheck_intf"; "Quickcheck_observer"; "Quickcheck_unit_tests"; "Raw_quickcheck_generator"; "Raw_quickcheck_observer"; "Ref"; "Result"; "Robustly_comparable"; "Rope"; "Sequence"; "Set_once"; "Sexpable"; "Source_code_position0"; "Source_code_position"; "Stable_containers"; "Stable_internal"; "Stable_module_types"; "Stable"; "Stable_unit_test_intf"; "Stable_unit_test"; "Stack_intf"; "Stack_unit_tests"; "Staged"; "Std_common"; "Std_internal"; "Std_kernel"; "Std"; "Stringable"; "String_id"; "Substring_intf"; "Substring"; "T"; "Thread_safe_queue"; "Time_ns"; "Time_ns_alternate_sexp"; "Timing_wheel_intf"; "Timing_wheel_ns"; "Timing_wheel_ns_unit_tests"; "Timing_wheel_unit_tests"; "Total_map"; "Tuple"; "Tuple_type"; "Tuple_type_intf"; "Type_equal"; "Type_immediacy"; "Type_immediacy_conv_unit_tests"; "Type_immediacy_witness_unit_tests"; "Union_find"; "Unique_id_intf"; "Unique_id"; "Unit"; "Univ_map"; "Univ_map_intf"; "Univ"; "Unpack_buffer"; "Validated_intf"; "Validated"; "Validate"; "With_return"; "Word_size" ]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = Some "core_kernel"; lib_findlib_containers = [] }); Library ({ cs_name = "check_caml_modify"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "caml_modify_test", true) ]; bs_install = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "caml_modify_test", true) ]; bs_path = "check_caml_modify"; bs_compiled_object = Best; bs_build_depends = [ FindlibPackage ("pa_ounit", None); FindlibPackage ("pa_ounit.syntax", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = ["caml_modify_stub.c"]; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = ["Caml_modify"]; lib_pack = true; lib_internal_modules = []; lib_findlib_parent = Some "core_kernel"; lib_findlib_name = Some "check_caml_modify"; lib_findlib_containers = [] }); Executable ({ cs_name = "pool_caml_modify_check"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EFlag "caml_modify_test"), true) ]; bs_install = [(OASISExpr.EBool true, false)]; bs_path = "test"; bs_compiled_object = Best; bs_build_depends = [ InternalLibrary "core_kernel"; InternalLibrary "check_caml_modify" ]; bs_build_tools = [ExternalTool "ocamlbuild"; ExternalTool "camlp4o"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { exec_custom = false; exec_main_is = "pool_caml_modify_check.ml" }); Test ({ cs_name = "test_pool_caml_modify_check"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { test_type = (`Test, "custom", Some "0.4"); test_command = [ (OASISExpr.EBool true, ("$pool_caml_modify_check", [])) ]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; test_working_directory = None; test_run = [ (OASISExpr.ENot (OASISExpr.EFlag "tests"), false); (OASISExpr.EFlag "tests", false); (OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EAnd (OASISExpr.EFlag "tests", OASISExpr.EFlag "caml_modify_test")), true) ]; test_tools = [ ExternalTool "ocamlbuild"; ExternalTool "camlp4o"; InternalExecutable "pool_caml_modify_check" ] }) ]; plugins = [ (`Extra, "StdFiles", Some "0.3"); (`Extra, "DevFiles", Some "0.3"); (`Extra, "META", Some "0.3") ]; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; oasis_digest = Some "-\192\185_\138\163\220g\234gu\011\162L\225\179"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 7373 "setup.ml" (* OASIS_STOP *) let () = InternalInstallPlugin.lib_hook := fun (cs, bs, lib) -> match lib.OASISTypes.lib_findlib_name with | Some "core_kernel" -> (cs, bs, lib, [ "src/core_params.h" ; "src/core_bigstring.h" ; "src/jane_common.h" ; "src/time_ns_stubs.h" ]) | _ -> (cs, bs, lib, []) ;; let () = setup () core_kernel-113.00.00/src/000077500000000000000000000000001256461164500151055ustar00rootroot00000000000000core_kernel-113.00.00/src/META000066400000000000000000000015231256461164500155570ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: 39cf882acd7addf0ffbd25136079679b) version = "113.00.00" description = "Jane Street Capital's standard library overlay" requires = "bin_prot custom_printf variantslib sexplib enumerate fieldslib bigarray pa_bench pa_ounit pa_test typerep_lib unix" archive(byte) = "core_kernel.cma" archive(byte, plugin) = "core_kernel.cma" archive(native) = "core_kernel.cmxa" archive(native, plugin) = "core_kernel.cmxs" exists_if = "core_kernel.cma" package "check_caml_modify" ( version = "113.00.00" description = "Jane Street Capital's standard library overlay" requires = "pa_ounit" archive(byte) = "check_caml_modify.cma" archive(byte, plugin) = "check_caml_modify.cma" archive(native) = "check_caml_modify.cmxa" archive(native, plugin) = "check_caml_modify.cmxs" exists_if = "check_caml_modify.cma" ) # OASIS_STOP core_kernel-113.00.00/src/applicative.ml000066400000000000000000000056411256461164500177460ustar00rootroot00000000000000include Applicative_intf module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t = struct include X let (<*>) = apply let derived_map t ~f = return f <*> t let map = match X.map with | `Define_using_apply -> derived_map | `Custom x -> x let map2 ta tb ~f = map ~f ta <*> tb let map3 ta tb tc ~f = map ~f ta <*> tb <*> tc let all ts = Core_list.fold_right ts ~init:(return []) ~f:(map2 ~f:(fun x xs -> x :: xs)) let both ta tb = map2 ta tb ~f:(fun a b -> (a, b)) let ( *> ) u v = return (fun () y -> y) <*> u <*> v let ( <* ) u v = return (fun x () -> x) <*> u <*> v module Applicative_infix = struct let ( <*> ) = ( <*> ) let ( *> ) = ( *> ) let ( <* ) = ( <* ) end end module Make (X : Basic) : S with type 'a t := 'a X.t = Make2 (struct type ('a, 'e) t = 'a X.t include (X : Basic with type 'a t := 'a X.t) end) module Make_args' (X : S2) = struct open X type ('f, 'r, 'e) t_ = { applyN : ('f, 'e) X.t -> ('r, 'e) X.t } let nil = { applyN = fun x -> x } let cons arg t = { applyN = fun d -> t.applyN (apply d arg) } let step t ~f = { applyN = fun d -> t.applyN (map ~f d) } let (@>) = cons let applyN arg t = t.applyN arg let mapN ~f t = applyN (return f) t end module Make_args (X : S) : Args with type 'a arg := 'a X.t = struct include Make_args' (struct type ('a, 'e) t = 'a X.t include (X : S with type 'a t := 'a X.t) end) type ('f, 'r) t = ('f, 'r, unit) t_ end module Make_args2 (X : S2) : Args2 with type ('a, 'e) arg := ('a, 'e) X.t = struct include Make_args' (X) type ('f, 'r, 'e) t = ('f, 'r, 'e) t_ end module Of_monad (M : Monad.S) : S with type 'a t := 'a M.t = Make (struct type 'a t = 'a M.t let return = M.return let apply mf mx = M.bind mf (fun f -> M.map mx ~f) let map = `Custom M.map end) module Compose (F : S) (G : S) : S with type 'a t = 'a F.t G.t = struct type 'a t = 'a F.t G.t include Make (struct type nonrec 'a t = 'a t let return a = G.return (F.return a) let apply tf tx = G.apply (G.map ~f:F.apply tf) tx let custom_map t ~f = G.map ~f:(F.map ~f) t let map = `Custom custom_map end) end module Pair (F : S) (G : S) : S with type 'a t = 'a F.t * 'a G.t = struct type 'a t = 'a F.t * 'a G.t include Make (struct type nonrec 'a t = 'a t let return a = (F.return a, G.return a) let apply tf tx = (F.apply (fst tf) (fst tx), G.apply (snd tf) (snd tx)) let custom_map t ~f = (F.map ~f (fst t), G.map ~f (snd t)) let map = `Custom custom_map end) end module Const (Monoid : sig type t val zero : t val plus : t -> t -> t end) : S with type 'a t = Monoid.t = struct type _ t = Monoid.t include Make (struct type nonrec 'a t = 'a t let return _a = Monoid.zero let apply tf tx = Monoid.plus tf tx let custom_map t ~f:_ = t let map = `Custom custom_map end) end core_kernel-113.00.00/src/applicative.mli000066400000000000000000000021131256461164500201060ustar00rootroot00000000000000include module type of Applicative_intf module Make (X : Basic ) : S with type 'a t := 'a X.t module Make2 (X : Basic2) : S2 with type ('a, 'e) t := ('a, 'e) X.t module Make_args (X : S ) : Args with type 'a arg := 'a X.t module Make_args2 (X : S2) : Args2 with type ('a, 'e) arg := ('a, 'e) X.t (** The following functors give a sense of what Applicatives one can define. Of these, [Of_monad] is likely the most useful. The others are mostly didactic. *) (** Every monad is Applicative via: {[ let apply mf mx = mf >>= fun f -> mx >>| fun x -> f x ]} *) module Of_monad (M : Monad.S) : S with type 'a t := 'a M.t module Compose (F : S) (G : S) : S with type 'a t = 'a F.t G.t module Pair (F : S) (G : S) : S with type 'a t = 'a F.t * 'a G.t (** Every monoid gives rise to a constant Applicative. *) module Const (Monoid : sig type t val zero : t val plus : t -> t -> t (** Laws: [plus] is associative and [zero] is both a left and right unit for [plus] *) end) : S with type 'a t = Monoid.t core_kernel-113.00.00/src/applicative_intf.ml000066400000000000000000000136611256461164500207670ustar00rootroot00000000000000(** Applicatives model computations in which values computed by subcomputations cannot affect what subsequent computations will take place. Relative to monads, this restriction takes power away from the user of the interface and gives it to the implementation. In particular, because the structure of the entire computation is known, one can augment its definition with some description of that structure. For more information, see: {v Applicative Programming with Effects. Conor McBride and Ross Paterson. Journal of Functional Programming 18:1 (2008), pages 1-13. http://staff.city.ac.uk/~ross/papers/Applicative.pdf v} *) module type Basic = sig type 'a t val return : 'a -> 'a t val apply : ('a -> 'b) t -> 'a t -> 'b t (** The following identities ought to hold for every Applicative (for some value of =): - [return Fn.id <*> t = t] - [return Fn.compose <*> tf <*> tg <*> tx = tf <*> (tg <*> tx)] - [return f <*> return x = return (f x)] - [tf <*> return x = return (fun f -> f x) <*> tf] Note: <*> is the infix notation for apply. *) (** The [map] argument to [Applicative.Make] says how to implement the applicative's [map] function. [`Define_using_apply] means to define [map t ~f = return f <*> t]. [`Custom] overrides the default implementation, presumably with something more efficient. Some other functions returned by [Applicative.Make] are defined in terms of [map], so passing in a more efficient [map] will improve their efficiency as well. *) val map : [`Define_using_apply | `Custom of ('a t -> f:('a -> 'b) -> 'b t)] end module type S = sig type 'a t val return : 'a -> 'a t val apply : ('a -> 'b) t -> 'a t -> 'b t val map : 'a t -> f:('a -> 'b) -> 'b t val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val map3 : 'a t -> 'b t -> 'c t -> f:('a -> 'b -> 'c -> 'd) -> 'd t val all : 'a t list -> 'a list t val both : 'a t -> 'b t -> ('a * 'b) t module Applicative_infix : sig val ( <*> ) : ('a -> 'b) t -> 'a t -> 'b t (** same as [apply] *) val ( <* ) : 'a t -> unit t -> 'a t val ( *> ) : unit t -> 'a t -> 'a t end include module type of Applicative_infix end (** argument lists and associated N-ary map and apply functions *) module type Args = sig type 'a arg (** the underlying applicative *) (** ['f] is the type of a function that consumes the list of arguments and returns an ['r]. *) type ('f, 'r) t (** the empty argument list **) val nil : ('r, 'r) t (** prepend an argument *) val cons : 'a arg -> ('f, 'r) t -> ('a -> 'f, 'r) t (** infix operator for [cons] *) val (@>) : 'a arg -> ('f, 'r) t -> ('a -> 'f, 'r) t (** Transform argument values in some way. For example, one can label a function argument like so: {[ step ~f:(fun f ~foo:x -> f x) : ('a -> 'r1, 'r2) t -> (foo:'a -> 'r1, 'r2) t ]} *) val step : ('f1, 'r) t -> f:('f2 -> 'f1) -> ('f2, 'r) t (** The preferred way to factor out an [Args] sub-sequence: {[ let args = Foo.Args.( bar "A" (* TODO: factor out the common baz qux sub-sequence *) @> baz "B" @> qux "C" @> zap "D" @> nil ) ]} is to write a function that prepends the sub-sequence: {[ let baz_qux remaining_args = Foo.Args.( baz "B" @> qux "C" @> remaining_args ) ]} and splice it back into the original sequence using [@@] so that things line up nicely: {[ let args = Foo.Args.( bar "A" @> baz_qux @@ zap "D" @> nil ) ]} *) val mapN : f:'f -> ('f, 'r) t -> 'r arg val applyN : 'f arg -> ('f, 'r) t -> 'r arg end module type Basic2 = sig type ('a, 'e) t val return : 'a -> ('a, _) t val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t val map : [`Define_using_apply | `Custom of (('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t)] end module type S2 = sig type ('a, 'e) t val return : 'a -> ('a, _) t val apply : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t val map : ('a, 'e) t -> f:('a -> 'b) -> ('b, 'e) t val map2 : ('a, 'e) t -> ('b, 'e) t -> f:('a -> 'b -> 'c) -> ('c, 'e) t val map3 : ('a, 'e) t -> ('b, 'e) t -> ('c, 'e) t -> f:('a -> 'b -> 'c -> 'd) -> ('d, 'e) t val all : ('a, 'e) t list -> ('a list, 'e) t val both : ('a, 'e) t -> ('b, 'e) t -> ('a * 'b, 'e) t module Applicative_infix : sig val ( <*> ) : ('a -> 'b, 'e) t -> ('a, 'e) t -> ('b, 'e) t val ( <* ) : ('a, 'e) t -> (unit, 'e) t -> ('a, 'e) t val ( *> ) : (unit, 'e) t -> ('a, 'e) t -> ('a, 'e) t end include module type of Applicative_infix end (** This module serves mostly as a partial check that [S2] and [S] are in sync, but actually calling it is occasionally useful. *) module S_to_S2 (X : S) : (S2 with type ('a, 'e) t = 'a X.t) = struct type ('a, 'e) t = 'a X.t include (X : S with type 'a t := 'a X.t) end module S2_to_S (X : S2) : (S with type 'a t = ('a, unit) X.t) = struct type 'a t = ('a, unit) X.t include (X : S2 with type ('a, 'e) t := ('a, 'e) X.t) end module type Args2 = sig type ('a, 'e) arg type ('f, 'r, 'e) t val nil : ('r, 'r, _) t val cons : ('a, 'e) arg -> ('f, 'r, 'e) t -> ('a -> 'f, 'r, 'e) t val (@>) : ('a, 'e) arg -> ('f, 'r, 'e) t -> ('a -> 'f, 'r, 'e) t val step : ('f1, 'r, 'e) t -> f:('f2 -> 'f1) -> ('f2, 'r, 'e) t val mapN : f:'f -> ('f, 'r, 'e) t -> ('r, 'e) arg val applyN : ('f, 'e) arg -> ('f, 'r, 'e) t -> ('r, 'e) arg end module Args_to_Args2 (X : Args) : ( Args2 with type ('a, 'e) arg = 'a X.arg with type ('f, 'r, 'e) t = ('f, 'r) X.t ) = struct type ('a, 'e) arg = 'a X.arg type ('f, 'r, 'e) t = ('f, 'r) X.t include (X : Args with type 'a arg := 'a X.arg and type ('f, 'r) t := ('f, 'r) X.t) end core_kernel-113.00.00/src/array_permute.ml000066400000000000000000000006661256461164500203260ustar00rootroot00000000000000(** An internal-only module factored out due to a circular dependency between core_array and core_list. Contains code for permuting an array. *) module Random = Core_random let swap t i j = let tmp = t.(i) in t.(i) <- t.(j); t.(j) <- tmp (** randomly permute an array. *) let permute ?(random_state = Random.State.default) t = for i = Array.length t downto 2 do swap t (i - 1) (Random.State.int random_state i) done core_kernel-113.00.00/src/avltree.ml000066400000000000000000000323131256461164500171030ustar00rootroot00000000000000(* A few small things copied from other parts of core because they depend on us, so we can't use them. *) module Int = struct type t = int let max (x : t) y = if x > y then x else y end let phys_equal = (==) (* Its important that Empty have no args. It's tempting to make this type a record (e.g. to hold the compare function), but a lot of memory is saved by Empty being an immediate, since all unused buckets in the hashtbl don't use any memory (besides the array cell) *) type ('k, 'v) t = | Empty | Node of ('k, 'v) t * 'k * 'v * int * ('k, 'v) t | Leaf of 'k * 'v (* We do this 'crazy' magic because we want to remove a level of indirection in the tree. If we didn't do this, we'd need to use a record, and then the variant would be a block with a pointer to the record. Where as now the 'record' is tagged with the constructor, thus removing a level of indirection. This is even reasonably safe, certainly no more dangerous than a C binding. The extra checking is probably free, since the block will already be in L1 cache, and the branch predictor is very likely to predict correctly. *) module Update : sig val leaf_val : ('k, 'v) t -> 'v -> unit val node_val : ('k, 'v) t -> 'v -> unit val node_left : ('k, 'v) t -> ('k, 'v) t -> unit val node_height : ('k, 'v) t -> int -> unit val node_right : ('k, 'v) t -> ('k, 'v) t -> unit end = struct let set_field (to_update: ('k, 'v) t) (n: int) v = Obj.set_field (Obj.repr to_update) n (Obj.repr v) let node_left to_update v = match to_update with | Node _ -> set_field to_update 0 v | _ -> assert false let leaf_val to_update v = match to_update with | Leaf _ -> set_field to_update 1 v | _ -> assert false let node_val to_update v = match to_update with | Node _ -> set_field to_update 2 v | _ -> assert false let node_height to_update v = match to_update with | Node _ -> set_field to_update 3 v | _ -> assert false let node_right to_update v = match to_update with | Node _ -> set_field to_update 4 v | _ -> assert false end let empty = Empty let height = function | Empty -> 0 | Leaf _ -> 1 | Node (_l, _k, _v, height, _r) -> height let invariant compare = let legal_left_key key = function | Empty -> () | Leaf (left_key, _) | Node (_, left_key, _, _, _) -> assert (compare left_key key < 0) in let legal_right_key key = function | Empty -> () | Leaf (right_key, _) | Node (_, right_key, _, _, _) -> assert (compare right_key key > 0) in let rec inv = function | Empty | Leaf _ -> () | Node (left, k, _v, h, right) -> let (hl, hr) = (height left, height right) in inv left; inv right; legal_left_key k left; legal_right_key k right; assert (h = Int.max hl hr + 1); assert (abs (hl - hr) <= 2) in inv let invariant t ~compare = invariant compare t (* In the following comments, 't is balanced' means that 'invariant t' does not raise an exception. This implies of course that each node's height field is correct. 't is balanceable' means that height of the left and right subtrees of t differ by at most 3. *) (* In the following comments, 't is balanced' means that 'invariant t' does not raise an exception. This implies of course that each node's height field is correct. 't is balanceable' means that height of the left and right subtrees of t differ by at most 3. *) (* @pre: left and right subtrees have correct heights @post: output has the correct height *) let update_height n = match n with | Node (left, _, _, old_height, right) -> let new_height = (Int.max (height left) (height right)) + 1 in if new_height <> old_height then Update.node_height n new_height | _ -> assert false (*let balanceable = function | Empty | Leaf _ -> true | Node(l, _, _, _, r) -> abs (height l - height r) <= 3*) (* @pre: left and right subtrees are balanced @pre: tree is balanceable @post: output is balanced (in particular, height is correct) *) let balance tree = (* assert (balanceable tree); *) match tree with | Empty | Leaf _ -> tree | Node (left, _k, _v, _h, right) as root_node -> let hl = height left and hr = height right in (* + 2 is critically important, lowering it to 1 will break the Leaf assumptions in the code below, and will force us to promote leaf nodes in the balance routine. It's also faster, since it will balance less often. Note that the following code is delicate. The update_height calls must occur in the correct order, since update_height assumes its children have the correct heights. *) if hl > hr + 2 then begin match left with (* It cannot be a leaf, because even if right is empty, a leaf is only height 1 *) | Empty | Leaf _ -> assert false | Node (left_node_left, _, _, _, left_node_right) as left_node -> if height left_node_left >= height left_node_right then begin Update.node_left root_node left_node_right; Update.node_right left_node root_node; update_height root_node; update_height left_node; left_node end else begin (* if right is a leaf, then left must be empty. That means height is 2. Even if hr is empty we still can't get here. *) match left_node_right with | Empty | Leaf _ -> assert false | Node (lr_left, _, _, _, lr_right) as lr_node -> Update.node_right left_node lr_left; Update.node_left root_node lr_right; Update.node_right lr_node root_node; Update.node_left lr_node left_node; update_height left_node; update_height root_node; update_height lr_node; lr_node end end else if hr > hl + 2 then begin (* see above for an explanation of why right cannot be a leaf *) match right with | Empty | Leaf _ -> assert false | Node (right_node_left, _, _, _, right_node_right) as right_node -> if height right_node_right >= height right_node_left then begin Update.node_right root_node right_node_left; Update.node_left right_node root_node; update_height root_node; update_height right_node; right_node end else begin (* see above for an explanation of why this cannot be a leaf *) match right_node_left with | Empty | Leaf _ -> assert false | Node (rl_left, _, _, _, rl_right) as rl_node -> Update.node_left right_node rl_right; Update.node_right root_node rl_left; Update.node_left rl_node root_node; Update.node_right rl_node right_node; update_height right_node; update_height root_node; update_height rl_node; rl_node end end else begin update_height tree; tree end ;; (* @pre: tree is balanceable @pre: abs (height (right node) - height (balance tree)) <= 3 @post: result is balanceable *) (* @pre: tree is balanceable @pre: abs (height (right node) - height (balance tree)) <= 3 @post: result is balanceable *) let set_left node tree = let tree = balance tree in match node with | Node (left, _, _, _, _) -> if phys_equal left tree then () else Update.node_left node tree; update_height node | _ -> assert false (* @pre: tree is balanceable @pre: abs (height (left node) - height (balance tree)) <= 3 @post: result is balanceable *) let set_right node tree = let tree = balance tree in match node with | Node (_, _, _, _, right) -> if phys_equal right tree then () else Update.node_right node tree; update_height node | _ -> assert false (* @pre: t is balanced. @post: result is balanced, with new node inserted @post: !added = true iff the shape of the input tree changed. *) let add = let rec add t replace added compare k v = match t with | Empty -> added := true; Leaf (k, v) | Leaf (k', _) -> let c = compare k' k in (* This compare is reversed on purpose, we are pretending that the leaf was just inserted instead of the other way round, that way we only allocate one node. *) if c = 0 then begin added := false; if replace then Update.leaf_val t v; t end else begin added := true; if c < 0 then Node(t, k, v, 2, Empty) else Node(Empty, k, v, 2, t) end | Node (left, k', _, _, right) -> let c = compare k k' in if c = 0 then begin added := false; if replace then Update.node_val t v; end else if c < 0 then set_left t (add left replace added compare k v) else set_right t (add right replace added compare k v); t in fun ?(replace = true) t ~compare ~added ~key ~data -> let replace = (replace :> bool) in let t = add t replace added compare key data in if !added then balance t else t ;; let rec first t = match t with | Empty -> None | Leaf (k, v) | Node (Empty, k, v, _, _) -> Some (k, v) | Node (l, _, _, _, _) -> first l ;; let rec last t = match t with | Empty -> None | Leaf (k, v) | Node (_, k, v, _, Empty) -> Some (k, v) | Node (_, _, _, _, r) -> last r ;; let rec find_and_call t ~compare k ~if_found ~if_not_found = (* A little manual unrolling of the recursion. This is really worth 5% on average *) match t with | Empty -> if_not_found k | Leaf (k', v) -> if compare k k' = 0 then if_found v else if_not_found k | Node (left, k', v, _, right) -> let c = compare k k' in if c = 0 then if_found v else if c < 0 then begin match left with | Empty -> if_not_found k | Leaf (k', v) -> if compare k k' = 0 then if_found v else if_not_found k | Node (left, k', v, _, right) -> let c = compare k k' in if c = 0 then if_found v else find_and_call (if c < 0 then left else right) ~compare k ~if_found ~if_not_found end else begin match right with | Empty -> if_not_found k | Leaf (k', v) -> if compare k k' = 0 then if_found v else if_not_found k | Node (left, k', v, _, right) -> let c = compare k k' in if c = 0 then if_found v else find_and_call (if c < 0 then left else right) ~compare k ~if_found ~if_not_found end ;; let find = let if_found v = Some v in let if_not_found _ = None in fun t ~compare k -> find_and_call t ~compare k ~if_found ~if_not_found let mem = let if_found _ = true in let if_not_found _ = false in fun t ~compare k -> find_and_call t ~compare k ~if_found ~if_not_found let remove = let rec min_elt tree = match tree with | Empty -> Empty | Leaf _ -> tree | Node (Empty, _, _, _, _) -> tree | Node (left, _, _, _, _) -> min_elt left in let rec remove_min_elt tree = match tree with | Empty -> assert false | Leaf _ -> Empty (* This must be the root *) | Node (Empty, _, _, _, right) -> right | Node (Leaf _, k, v, _, Empty) -> Leaf (k, v) | Node (Leaf _, _, _, _, _) as node -> set_left node Empty; tree | Node (left, _, _, _, _) as node -> set_left node (remove_min_elt left); tree in let merge t1 t2 = match (t1, t2) with | (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let tree = min_elt t2 in match tree with | Empty -> assert false | Leaf (k, v) -> let t2 = balance (remove_min_elt t2) in Node (t1, k, v, Int.max (height t1) (height t2) + 1, t2) | Node _ as node -> set_right node (remove_min_elt t2); set_left node t1; node in let rec remove t removed compare k = match t with | Empty -> removed := false; Empty | Leaf (k', _) -> if compare k k' = 0 then begin removed := true; Empty end else begin removed := false; t end | Node (left, k', _, _, right) -> let c = compare k k' in if c = 0 then begin removed := true; merge left right end else if c < 0 then begin set_left t (remove left removed compare k); t end else begin set_right t (remove right removed compare k); t end in fun t ~removed ~compare k -> balance (remove t removed compare k) ;; let rec fold t ~init ~f = match t with | Empty -> init | Leaf (key, data) -> f ~key ~data init | Node (Leaf (lkey, ldata), key, data, _, Leaf (rkey, rdata)) -> f ~key:rkey ~data:rdata (f ~key ~data (f ~key:lkey ~data:ldata init)) | Node (Leaf (lkey, ldata), key, data, _, Empty) -> f ~key ~data (f ~key:lkey ~data:ldata init) | Node (Empty, key, data, _, Leaf (rkey, rdata)) -> f ~key:rkey ~data:rdata (f ~key ~data init) | Node (left, key, data, _, Leaf (rkey, rdata)) -> f ~key:rkey ~data:rdata (f ~key ~data (fold left ~init ~f)) | Node (Leaf (lkey, ldata), key, data, _, right) -> fold right ~init:(f ~key ~data (f ~key:lkey ~data:ldata init)) ~f | Node (left, key, data, _, right) -> fold right ~init:(f ~key ~data (fold left ~init ~f)) ~f let iter t ~f = fold t ~init:() ~f:(fun ~key ~data () -> f ~key ~data) core_kernel-113.00.00/src/avltree.mli000066400000000000000000000117041256461164500172550ustar00rootroot00000000000000(** A low-level, mutable AVL tree. It is not intended to be used directly by casual users. It is used for implementing other data structures. The interface is somewhat ugly, and it's that way for a reason. The goal of this module is minimum memory overhead, and maximum performance. ***************** Points of Ugliness ***************** * compare is passed in to every function where it is used. If you pass a different compare to functions on the same tree, then all bets are off as far as what it does, and it's all your fault. Why? Because otherwise we'd need a top level record to store compare, and when building a hash table, or other structure, that little t is a block that increases memory overhead. However, if an empty tree is just a constructor 'Empty', then it's just a number, and uses no extra memory beyond the array bucket that holds it. That's the first secret of how Core_hashtbl's memory overhead isn't higher than INRIA's, even though it uses a tree instead of a list for buckets. * But you said it's mutable, why do all the 'mutators' return t. Answer, it is mutable, but the root node might change due to balancing. Since we have no top level record to hold the current root node (see point 1), you have to do it. If you fail to do it, and use an old root node, you're responsible for the (sure to be nasty) consequences. * What on earth is up with the ~removed argument to some functions. See point 1, since there is no top level node, it isn't possible to keep track of how many nodes are in the tree unless each mutator tells you whether or not it added or removed a node, vs replacing an existing one. If you intend to keep a count (as you must in a hash table), then you will need to pay attention to this flag. After all this, you're probably asking yourself whether all these hacks are worth it. Yes! They are! With them, we built a hash table that is faster than INRIA's (no small feat actually), with the same memory overhead, with sane add semantics (the add semantics they used were a performance hack), and with worst case log(N) insertion, lookup, and removal. I'd say that's worth it. But for those of you who will feel morally compelled to put in a CR about this interface. I challenge you to write a better interface, implement a hash table with it, and show that your table has better performance than Core_hashtbl. *) (* estokes: We expose [t] to allow an optimization in Hashtbl that makes iter and fold more than twice as fast. *) type ('k, 'v) t = | Empty | Node of ('k, 'v) t * 'k * 'v * int * ('k, 'v) t | Leaf of 'k * 'v val empty : ('k, 'v) t (** check invariants, raise an exception if any invariants fail *) val invariant : ('k, 'v) t -> compare:('k -> 'k -> int) -> unit (** adds the specified key and data to the tree destructively (previous t's are no longer valid) using the specified comparison function. O(log(N)) time, O(1) space. The returned t is the new root node of the tree, and should be used on all further calls to any other function in this module. The bool ref, added, will be set to true if a new node is added to the tree, or false if an existing node is replaced (in the case that the key already exists). If [replace] (default true) is true then add will overwrite any existing mapping for [key]. If [replace] is false, and there is an existing mapping for key then add has no effect. *) val add : ?replace:bool (* defaults to true *) -> ('k, 'v) t -> compare:('k -> 'k -> int) -> added:bool ref -> key:'k -> data:'v -> ('k, 'v) t (* Returns the first (leftmost) or last (rightmost) element in the tree *) val first : ('k, 'v) t -> ('k * 'v) option val last : ('k, 'v) t -> ('k * 'v) option (** if the specified key exists in the tree, return the corresponding value. O(log(N)) time and O(1) space. *) val find : ('k, 'v) t -> compare:('k -> 'k -> int) -> 'k -> 'v option (** [find_and_call t ~compare k ~if_found ~if_not_found] is equivalent to: [match find t ~compare k with Some v -> if_found v | None -> if_not_found k] except that it doesn't allocate the option. *) val find_and_call : ('k, 'v) t -> compare:('k -> 'k -> int) -> 'k -> if_found:('v -> 'a) -> if_not_found:('k -> 'a) -> 'a (** return true if key is present in the tree, otherwise return false. *) val mem : ('k, 'v) t -> compare:('k -> 'k -> int) -> 'k -> bool (** remove key destructively from the tree if it exists, return the new root node. Previous root nodes are not usable anymore, do so at your peril. the removed ref will be set to true if a node was actually removed, or false otherwise. *) val remove : ('k, 'v) t -> removed:bool ref -> compare:('k -> 'k -> int) -> 'k -> ('k, 'v) t (** fold over the tree *) val fold : ('k, 'v) t -> init:'a -> f:(key:'k -> data:'v -> 'a -> 'a) -> 'a (** iterate over the tree *) val iter : ('k, 'v) t -> f:(key:'k -> data:'v -> unit) -> unit core_kernel-113.00.00/src/backtrace.ml000066400000000000000000000020031256461164500173510ustar00rootroot00000000000000open Std_internal module Sexp = Sexplib.Sexp type t = Printexc.raw_backtrace let get ?(at_most_num_frames = Int.max_value) () = Printexc.get_callstack at_most_num_frames ;; let to_string = Printexc.raw_backtrace_to_string let sexp_of_t t = Sexp.List (List.map (String.split (to_string t) ~on:'\n') ~f:(fun x -> Sexp.Atom x)) ;; TEST_UNIT = let t = get () in assert (String.length (to_string t) > 0); ;; module Exn = struct let set_recording = Printexc.record_backtrace let am_recording = Printexc.backtrace_status let most_recent = Printexc.get_backtrace (* We turn on backtraces by default if OCAMLRUNPARAM isn't set. *) let () = match Sys.getenv "OCAMLRUNPARAM" with | exception _ -> set_recording true | _ -> () (* the caller set something, they are responsible *) ;; let with_recording b ~f = let saved = am_recording () in set_recording b; protect ~f ~finally:(fun () -> set_recording saved) ;; TEST = "" = with_recording false ~f:most_recent end core_kernel-113.00.00/src/backtrace.mli000066400000000000000000000054021256461164500175300ustar00rootroot00000000000000(** Dealing with stack backtraces. The [Backtrace] module deals with two different kinds of backtraces: 1. snapshots of the stack obtained on demand ([Backtrace.get]) 2. the stack frames unwound when an exception is raised ([Backtrace.Exn]) *) open Std_internal (** A [Backtrace.t] is a snapshot of the stack obtained by calling [Backtrace.get]. It is represented as a string with newlines separating the frames. [sexp_of_t] splits the string at newlines and removes some of the cruft, leaving a human-friendly list of frames, but [to_string] does not. *) type t with sexp_of val get : ?at_most_num_frames:int -> unit -> t val to_string : t -> string (** [Backtrace.Exn] has functions for controlling and printing the backtrace of the most recently raised exception. When an exception is raised, the runtime "unwinds" the stack, i.e. removes stack frames, until it reaches a frame with an exception handler. It then matches the exception against the patterns in the handler. If the exception matches, then the program continues. If not, then the runtime continues unwinding the stack to the next handler. If [am_recording () = true], then the runtime, while it is unwinding the stack, keeps track of the part of the stack that is unwound. This is available as a human-readable string via [most_recent ()]. Calling [most_recent] if [am_recording () = false] will yield the empty string. With [am_recording () = true], OCaml keeps only a backtrace for the most recently raised exception. When one raises an exception, OCaml checks if it is physically equal to the most recently raised exception. If they are equal, then OCaml appends the string representation of the stack unwound by the current raise to the stored backtrace. If the exception being raised is not physically equally to the most recently raised exception, then OCaml starts recording a new backtrace. Thus one must call [most_recent] before a subsequent [raise] of a (physically) distinct exception, or the backtrace is lost. The initial value of [am_recording ()] is determined by the setting of the environment variable OCAMLRUNPARAM. If OCAMLRUNPARAM is set, then [am_recording () = true] iff the character "b" occurs in OCAMLRUNPARAM. If OCAMLRUNPARAM is not set, then [am_recording ()] is initially true. This is the same functionality as provided by the OCaml stdlib [Printexc] functions [backtrace_status], [record_backtraces], [get_backtrace]. *) module Exn : sig val am_recording : unit -> bool val set_recording : bool -> unit (** [most_recent ()] returns a string containing the stack that was unwound by the most recently raised exception. *) val most_recent : unit -> string end core_kernel-113.00.00/src/bag.ml000066400000000000000000000004351256461164500161720ustar00rootroot00000000000000include Doubly_linked let add = insert_first let elts t = fold_elt t ~init:[] ~f:(fun acc elt -> elt :: acc) let remove_one = remove_first let choose = first_elt let until_empty t f = let rec loop () = Option.iter (remove_one t) ~f:(fun v -> f v; loop ()) in loop () ;; core_kernel-113.00.00/src/bag.mli000066400000000000000000000051241256461164500163430ustar00rootroot00000000000000(** Imperative set-like data structure. Primary differences from a simple set: - It doesn't require anything (hashable, comparable) of elements in the bag. - Duplicates are allowed. - Addition and removal are constant time. It is an error to modify a bag ([add], [remove], [remove_one], ...) during iteration ([fold], [iter], ...). *) open Std_internal module Elt : sig type 'a t val equal : 'a t -> 'a t -> bool val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t val value : 'a t -> 'a end type 'a t with sexp include Container.S1 with type 'a t := 'a t val invariant : 'a t -> unit (** [create ()] returns an empty bag. *) val create : unit -> 'a t (** [add t v] adds [v] to the bag [t], returning an element that can later be removed from the bag. [add] runs in constant time. *) val add : 'a t -> 'a -> 'a Elt.t (** [remove t elt] removes [elt] from the bag [t], raising an exception if [elt] is not in the bag. [remove] runs in constant time. *) val remove : 'a t -> 'a Elt.t -> unit (** [choose t] returns some element in the bag. *) val choose : 'a t -> 'a Elt.t option (** [remove_one t] removes some element from the bag, and returns its value. [remove_one] runs in constant time. *) val remove_one : 'a t -> 'a option (** [clear t] removes all elements from the bag. [clear] runs in O(1) time. *) val clear : 'a t -> unit (** [filter_inplace t ~f] removes all the elements from [t] that don't satisfy [f]. *) val filter_inplace : 'a t -> f:('a -> bool) -> unit val iter_elt : 'a t -> f:('a Elt.t -> unit) -> unit (** [find_elt t ~f] looks at elements in the bag one-by-one until it finds one [elt] such that [f (Elt.value elt)], in which case it returns [Some elt]. If there is no element satisfying [f], then [find_elt] returns [None]. *) val find_elt : 'a t -> f:('a -> bool) -> 'a Elt.t option (** [until_empty t f] repeatedly removes a value [v] from [t] and runs [f v], continuing until [t] is empty. Running [f] may add elements to [t] if it wants. *) val until_empty : 'a t -> ('a -> unit) -> unit (** [transfer ~src ~dst] moves all of the elements from [src] to [dst] in constant time. *) val transfer : src:'a t -> dst:'a t -> unit val of_list : 'a list -> 'a t val elts : 'a t -> 'a Elt.t list (** [unchecked_iter t ~f] behaves like [iter t ~f] except that [f] is allowed to modify [t]. Elements added by [f] may or may not be visited, elements removed by [f] that have not been visited will not be visited. It is an (undetected) error to delete the current element. *) val unchecked_iter : 'a t -> f:('a -> unit) -> unit core_kernel-113.00.00/src/bigbuffer.ml000066400000000000000000000114561256461164500174010ustar00rootroot00000000000000(* Some code taken from INRIA's buffer module. *) open Bigstring include Bigbuffer_internal let __internal (t : t) = t let length t = t.pos (* let invariant t = assert (t.len == Bigstring.length t.bstr); ;; *) let create n = let n = max 1 n in let bstr = Bigstring.create n in { bstr = bstr; pos = 0; len = n; init = bstr; } let contents buf = Bigstring.to_string buf.bstr ~len:buf.pos let big_contents buf = subo ~len:buf.pos buf.bstr let volatile_contents buf = buf.bstr let add_char buf c = let pos = buf.pos in if pos >= buf.len then resize buf 1; buf.bstr.{pos} <- c; buf.pos <- pos + 1; ;; include Blit.Make_distinct (struct type t = char let equal = (=) let of_bool b = if b then 'a' else 'b' end) (struct type nonrec t = t with sexp_of let create ~len = let t = create len in for _i = 1 to len do add_char t 'a'; done; t ;; let length = length let set t i c = Bigstring.set t.bstr i c let get t i = Bigstring.get t.bstr i end) (struct include Core_string let create ~len = create len let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len = Bigstring.To_string.unsafe_blit ~src:src.bstr ~src_pos ~dst ~dst_pos ~len ;; end) ;; let nth buf pos = if pos < 0 || pos >= buf.pos then invalid_arg "Bigbuffer.nth" else buf.bstr.{pos} let clear buf = buf.pos <- 0 let reset buf = buf.pos <- 0; buf.bstr <- buf.init; buf.len <- Bigstring.length buf.bstr; ;; let add_substring buf src src_pos len = if src_pos < 0 || len < 0 || src_pos > String.length src - len then invalid_arg "Bigbuffer.add_substring"; let new_pos = buf.pos + len in if new_pos > buf.len then resize buf len; Bigstring.From_string.blit ~src ~src_pos ~len ~dst:buf.bstr ~dst_pos:buf.pos; buf.pos <- new_pos; ;; let add_string buf src = let len = String.length src in let new_pos = buf.pos + len in if new_pos > buf.len then resize buf len; Bigstring.From_string.blito ~src ~src_len:len ~dst:buf.bstr ~dst_pos:buf.pos (); buf.pos <- new_pos; ;; let add_buffer buf_dst buf_src = let len = buf_src.pos in let dst_pos = buf_dst.pos in let new_pos = dst_pos + len in if new_pos > buf_dst.len then resize buf_dst len; Bigstring.blito ~src:buf_src.bstr ~src_len:len ~dst:buf_dst.bstr ~dst_pos (); buf_dst.pos <- new_pos; ;; let closing = function | '(' -> ')' | '{' -> '}' | _ -> assert false (* opening and closing: open and close characters, typically ( and ) k: balance of opening and closing chars s: the string where we are searching start: the index where we start the search. *) let advance_to_closing opening closing k s start = let rec advance k i lim = if i >= lim then raise Not_found else if s.[i] = opening then advance (k + 1) (i + 1) lim else if s.[i] = closing then if k = 0 then i else advance (k - 1) (i + 1) lim else advance k (i + 1) lim in advance k start (String.length s) let advance_to_non_alpha s start = let rec advance i lim = if i >= lim then lim else match s.[i] with | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | 'é'|'à'|'á'|'è'|'ù'|'â'|'ê'| 'î'|'ô'|'û'|'ë'|'ï'|'ü'|'ç'| 'É'|'À'|'Á'|'È'|'Ù'|'Â'|'Ê'| 'Î'|'Ô'|'Û'|'Ë'|'Ï'|'Ü'|'Ç' -> advance (i + 1) lim | _ -> i in advance start (String.length s) (* We are just at the beginning of an ident in s, starting at start. *) let find_ident s start = match s.[start] with (* Parenthesized ident ? *) | '(' | '{' as c -> let new_start = start + 1 in let stop = advance_to_closing c (closing c) 0 s new_start in String.sub s new_start (stop - start - 1), stop + 1 (* Regular ident *) | _ -> let stop = advance_to_non_alpha s (start + 1) in String.sub s start (stop - start), stop (* Substitute $ident, $(ident), or ${ident} in s, according to the function mapping f. *) let add_substitute buf f s = let lim = String.length s in let rec subst previous i = if i < lim then begin match s.[i] with | '$' as current when previous = '\\' -> add_char buf current; subst current (i + 1) | '$' -> let ident, next_i = find_ident s (i + 1) in add_string buf (f ident); subst ' ' next_i | current when previous = '\\' -> add_char buf '\\'; add_char buf current; subst current (i + 1) | '\\' as current -> subst current (i + 1) | current -> add_char buf current; subst current (i + 1) end in subst ' ' 0 module Format = struct let formatter_of_buffer buf = Format.make_formatter (add_substring buf) ignore let bprintf buf = Format.kfprintf ignore (formatter_of_buffer buf) end module Printf = struct let bprintf buf = Printf.ksprintf (add_string buf) end core_kernel-113.00.00/src/bigbuffer.mli000066400000000000000000000107551256461164500175530ustar00rootroot00000000000000(** Extensible string buffers based on Bigstrings. This module implements string buffers that automatically expand as necessary. It provides accumulative concatenation of strings in quasi-linear time (instead of quadratic time when strings are concatenated pairwise). This implementation uses Bigstrings instead of strings. This removes the 16MB limit on buffer size, and improves I/O-performance when reading/writing from/to channels. *) type t with sexp_of (** The abstract type of buffers. *) val create : int -> t (** [create n] returns a fresh buffer, initially empty. The [n] parameter is the initial size of the internal string that holds the buffer contents. That string is automatically reallocated when more than [n] characters are stored in the buffer, but shrinks back to [n] characters when [reset] is called. For best performance, [n] should be of the same order of magnitude as the number of characters that are expected to be stored in the buffer (for instance, 80 for a buffer that holds one output line). Nothing bad will happen if the buffer grows beyond that limit, however. In doubt, take [n = 16] for instance. *) val contents : t -> string (** Return a copy of the current contents of the buffer. The buffer itself is unchanged. *) val big_contents : t -> Bigstring.t (** Return a copy of the current contents of the buffer as a bigstring. The buffer itself is unchanged. *) val volatile_contents : t -> Bigstring.t (** Return the actual underlying bigstring used by this bigbuffer. No copying is involved. To be safe, use and finish with the returned value before calling any other function in this module on the same [Bigbuffer.t]. *) include Blit.S_distinct with type src := t with type dst := string (** [blit ~src ~src_pos ~dst ~dst_pos ~len] copies [len] characters from the current contents of the buffer [src], starting at offset [src_pos] to string [dst], starting at character [dst_pos]. Raise [Invalid_argument] if [src_pos] and [len] do not designate a valid substring of [src], or if [dst_pos] and [len] do not designate a valid substring of [dst]. *) val nth : t -> int -> char (** get the (zero-based) n-th character of the buffer. Raise [Invalid_argument] if index out of bounds *) val length : t -> int (** Return the number of characters currently contained in the buffer. *) val clear : t -> unit (** Empty the buffer. *) val reset : t -> unit (** Empty the buffer and deallocate the internal string holding the buffer contents, replacing it with the initial internal string of length [n] that was allocated by {!Bigbuffer.create} [n]. For long-lived buffers that may have grown a lot, [reset] allows faster reclamation of the space used by the buffer. *) val add_char : t -> char -> unit (** [add_char b c] appends the character [c] at the end of the buffer [b]. *) val add_string : t -> string -> unit (** [add_string b s] appends the string [s] at the end of the buffer [b]. *) val add_substring : t -> string -> int -> int -> unit (** [add_substring b s ofs len] takes [len] characters from offset [ofs] in string [s] and appends them at the end of the buffer [b]. *) val add_substitute : t -> (string -> string) -> string -> unit (** [add_substitute b f s] appends the string pattern [s] at the end of the buffer [b] with substitution. The substitution process looks for variables into the pattern and substitutes each variable name by its value, as obtained by applying the mapping [f] to the variable name. Inside the string pattern, a variable name immediately follows a non-escaped [$] character and is one of the following: - a non empty sequence of alphanumeric or [_] characters, - an arbitrary sequence of characters enclosed by a pair of matching parentheses or curly brackets. An escaped [$] character is a [$] that immediately follows a backslash character; it then stands for a plain [$]. Raise [Not_found] if the closing character of a parenthesized variable cannot be found. *) val add_buffer : t -> t -> unit (** [add_buffer b1 b2] appends the current contents of buffer [b2] at the end of buffer [b1]. [b2] is not modified. *) (** NOTE: additions *) module Format : sig open Format val formatter_of_buffer : t -> formatter val bprintf : t -> ('a, formatter, unit) format -> 'a end module Printf : sig val bprintf : t -> ('a, unit, string, unit) format4 -> 'a end (**/**) (** For Core.Std.Bigbuffer, not for users! *) val __internal : t -> Bigbuffer_internal.t core_kernel-113.00.00/src/bigbuffer_internal.ml000066400000000000000000000006231256461164500212670ustar00rootroot00000000000000open Sexplib.Conv type t = { mutable bstr : Bigstring.t; mutable pos : int; mutable len : int; init : Bigstring.t; } with sexp_of let resize buf more = let min_len = buf.len + more in let new_len = min_len + min_len in let new_buf = Bigstring.create new_len in Bigstring.blito ~src:buf.bstr ~src_len:buf.pos ~dst:new_buf (); buf.bstr <- new_buf; buf.len <- new_len; ;; core_kernel-113.00.00/src/bigstring.ml000066400000000000000000000564551256461164500174460ustar00rootroot00000000000000INCLUDE "config.mlh" open Std_internal open Bigarray module Binable = Binable0 module Z : sig type t = (char, int8_unsigned_elt, c_layout) Array1.t with bin_io, sexp end = struct include Bin_prot.Std include Sexplib.Conv type t = bigstring with bin_io, sexp end include Z external aux_create: max_mem_waiting_gc:int -> size:int -> t = "bigstring_alloc" let create ?max_mem_waiting_gc size = let max_mem_waiting_gc = match max_mem_waiting_gc with | None -> ~-1 | Some v -> Float.to_int (Byte_units.bytes v) in if size < 0 then invalid_argf "create: size = %d < 0" size (); aux_create ~max_mem_waiting_gc ~size TEST "create with different max_mem_waiting_gc" = Core_gc.full_major (); let module Alarm = Core_gc.Expert.Alarm in let count_gc_cycles mem_units = let cycles = ref 0 in let alarm = Alarm.create (fun () -> incr cycles) in let large_int = 10_000 in let max_mem_waiting_gc = Byte_units.create mem_units 256. in for _i = 0 to large_int do let (_ : t) = create ~max_mem_waiting_gc large_int in () done; Alarm.delete alarm; !cycles in let large_max_mem = count_gc_cycles `Megabytes in let small_max_mem = count_gc_cycles `Bytes in (* We don't care if it's twice as many, we are only testing that there are less cycles involved *) (2 * large_max_mem) < small_max_mem let length = Array1.dim external is_mmapped : t -> bool = "bigstring_is_mmapped_stub" "noalloc" let init n ~f = let t = create n in for i = 0 to n - 1; do t.{i} <- f i; done; t ;; let check_args ~loc ~pos ~len (bstr : t) = if pos < 0 then invalid_arg (loc ^ ": pos < 0"); if len < 0 then invalid_arg (loc ^ ": len < 0"); let bstr_len = length bstr in if bstr_len < pos + len then invalid_arg (sprintf "Bigstring.%s: length(bstr) < pos + len" loc) let get_opt_len bstr ~pos = function | Some len -> len | None -> length bstr - pos let sub_shared ?(pos = 0) ?len (bstr : t) = let len = get_opt_len bstr ~pos len in Array1.sub bstr pos len (* Blitting *) external unsafe_blit : src : t -> src_pos : int -> dst : t -> dst_pos : int -> len : int -> unit = "bigstring_blit_stub" (* Exposing the external version of get/set supports better inlining *) external get : t -> int -> char = "%caml_ba_ref_1" external set : t -> int -> char -> unit = "%caml_ba_set_1" module Bigstring_sequence = struct type nonrec t = t with sexp_of let create ~len = create len let get = get let set = set let length = length end module String_sequence = struct type t = string with sexp_of let create ~len = String.create len let get = String.get let set = String.set let length = String.length end module Blit_elt = struct include Char let of_bool b = if b then 'a' else 'b' end include Blit.Make (Blit_elt) (struct include Bigstring_sequence let unsafe_blit = unsafe_blit end) module From_string = Blit.Make_distinct (Blit_elt) (String_sequence) (struct external unsafe_blit : src : string -> src_pos : int -> dst : t -> dst_pos : int -> len : int -> unit = "bigstring_blit_string_bigstring_stub" "noalloc" include Bigstring_sequence end) ;; module To_string = Blit.Make_distinct (Blit_elt) (Bigstring_sequence) (struct external unsafe_blit : src : t -> src_pos : int -> dst : string -> dst_pos : int -> len : int -> unit = "bigstring_blit_bigstring_string_stub" "noalloc" include String_sequence end) ;; let of_string = From_string.subo let to_string = To_string.subo (* Comparison *) external unsafe_memcmp : t1 : t -> t1_pos : int -> t2 : t -> t2_pos : int -> len : int -> int = "bigstring_memcmp_stub" "noalloc" let compare t1 t2 = if phys_equal t1 t2 then 0 else let len1 = length t1 in let len2 = length t2 in let len = Int.min len1 len2 in match unsafe_memcmp ~t1 ~t1_pos:0 ~t2 ~t2_pos:0 ~len with | 0 -> if len1 < len2 then -1 else if len1 > len2 then 1 else 0 | n -> n let equal t1 t2 = if phys_equal t1 t2 then true else let len1 = length t1 in let len2 = length t2 in Int.equal len1 len2 && Int.equal (unsafe_memcmp ~t1 ~t1_pos:0 ~t2 ~t2_pos:0 ~len:len1) 0 TEST_MODULE "comparison" = struct let sign n = if n < 0 then ~-1 else if n > 0 then 1 else 0 let check t1 t2 int = let bool = match int with 0 -> true | _ -> false in <:test_result< int >> (sign (compare t1 t2)) ~expect:int; <:test_result< bool >> (equal t1 t2) ~expect:bool TEST_UNIT = let t = of_string "cat" in check t t 0 TEST_UNIT = check (of_string "cat") (of_string "cat") 0 TEST_UNIT = check (of_string "cat") (of_string "cab") 1 TEST_UNIT = check (of_string "cat") (of_string "caz") ~-1 TEST_UNIT = check (of_string "cat") (of_string "c") 1 TEST_UNIT = check (of_string "c") (of_string "cat") ~-1 TEST_UNIT = check (of_string "cat") (of_string "dog") ~-1 TEST_UNIT = check (of_string "dog") (of_string "cat") 1 end BENCH_MODULE "comparison" = struct let t1 = of_string "microsoft" let t2 = of_string "microsoff" BENCH "equal" = equal t1 t2 end (* Reading / writing bin-prot *) let read_bin_prot_verbose_errors t ?(pos=0) ?len reader = let len = get_opt_len t len ~pos in let limit = pos + len in check_args ~loc:"read_bin_prot_verbose_errors" t ~pos ~len; let invalid_data message a sexp_of_a = `Invalid_data (Error.create message a sexp_of_a) in let read bin_reader ~pos ~len = if len > limit - pos then `Not_enough_data else let pos_ref = ref pos in match (try `Ok (bin_reader t ~pos_ref) with exn -> `Invalid_data (Error.of_exn exn)) with | `Invalid_data _ as x -> x | `Ok result -> let expected_pos = pos + len in if !pos_ref = expected_pos then `Ok (result, expected_pos) else invalid_data "pos_ref <> expected_pos" (!pos_ref, expected_pos) <:sexp_of< int * int >> in match read Bin_prot.Utils.bin_read_size_header ~pos ~len:Bin_prot.Utils.size_header_length with | `Not_enough_data | `Invalid_data _ as x -> x | `Ok (element_length, pos) -> if element_length < 0 then invalid_data "negative element length %d" element_length <:sexp_of< int >> else read reader.Bin_prot.Type_class.read ~pos ~len:element_length ;; TEST_MODULE = struct let make_t ~size input = (* We hardcode the size here to catch problems if [Bin_prot.Utils.size_header_length] ever changes. *) let t = create (String.length input + 8) in ignore (Bin_prot.Write.bin_write_int_64bit t ~pos:0 size : int); List.iteri (String.to_list input) ~f:(fun i c -> set t (i+8) c); t let test (type a) ~size input ?pos ?len reader sexp_of_a compare_a ~expect = let result = match read_bin_prot_verbose_errors (make_t ~size input) ?pos ?len reader with | `Ok (x, _bytes_read) -> `Ok x | `Not_enough_data -> `Not_enough_data | `Invalid_data _ -> `Invalid_data in <:test_result< [ `Ok of a | `Not_enough_data | `Invalid_data ] >> result ~expect let test_int ?pos ?len ~size input ~expect = test ~size input ?pos ?len Int.bin_reader_t Int.sexp_of_t Int.compare ~expect let test_string ?pos ?len ~size input ~expect = test ~size input ?pos ?len String.bin_reader_t String.sexp_of_t String.compare ~expect (* Keep in mind that the string bin-prot representation is itself prefixed with a length, so strings under the length-prefixed bin-prot protocol end up with two lengths at the front. *) TEST_UNIT = test_int ~size:1 "\042" ~expect:(`Ok 42) TEST_UNIT = test_int ~size:1 "\042suffix" ~expect:(`Ok 42) TEST_UNIT = test_string ~size:4 "\003foo" ~expect:(`Ok "foo") TEST_UNIT = test_string ~size:4 "\003foo" ~len:12 ~expect:(`Ok "foo") TEST "pos <> 0" = let t = ("prefix" ^ to_string (make_t ~size:4 "\003foo") ^ "suffix") |> of_string in read_bin_prot_verbose_errors t ~pos:6 String.bin_reader_t = `Ok ("foo", 18) TEST_UNIT "negative size" = test_string ~size:(-1) "\003foo" ~expect:`Invalid_data TEST_UNIT "wrong size" = test_string ~size:3 "\003foo" ~expect:`Invalid_data TEST_UNIT "bad bin-prot" = test_string ~size:4 "\007foo" ~expect:`Invalid_data TEST_UNIT "len too short" = test_string ~size:4 "\003foo" ~len:3 ~expect:`Not_enough_data TEST "no header" = let t = of_string "\003foo" in read_bin_prot_verbose_errors t String.bin_reader_t = `Not_enough_data end let read_bin_prot t ?pos ?len reader = match read_bin_prot_verbose_errors t ?pos ?len reader with | `Ok x -> Ok x | `Invalid_data e -> Error (Error.tag e "Invalid data") | `Not_enough_data -> Or_error.error_string "not enough data" let write_bin_prot t ?(pos = 0) writer v = let data_len = writer.Bin_prot.Type_class.size v in let total_len = data_len + Bin_prot.Utils.size_header_length in if pos < 0 then failwiths "Bigstring.write_bin_prot: negative pos" pos <:sexp_of< int >>; if pos + total_len > length t then failwiths "Bigstring.write_bin_prot: not enough room" (`pos pos, `pos_after_writing (pos + total_len), `bigstring_length (length t)) <:sexp_of<[`pos of int] * [`pos_after_writing of int] * [`bigstring_length of int]>>; let pos_after_size_header = Bin_prot.Utils.bin_write_size_header t ~pos data_len in let pos_after_data = writer.Bin_prot.Type_class.write t ~pos:pos_after_size_header v in if pos_after_data - pos <> total_len then begin failwiths "Bigstring.write_bin_prot bug!" (`pos_after_data pos_after_data, `start_pos pos, `bin_prot_size_header_length Bin_prot.Utils.size_header_length, `data_len data_len, `total_len total_len) <:sexp_of< [`pos_after_data of int] * [`start_pos of int] * [`bin_prot_size_header_length of int] * [`data_len of int] * [`total_len of int] >> end; pos_after_data TEST_MODULE = struct let test ?pos writer v ~expect = let size = writer.Bin_prot.Type_class.size v + 8 in let t = create size in ignore (write_bin_prot t ?pos writer v : int); <:test_result< string >> (to_string t) ~expect TEST_UNIT = test String.bin_writer_t "foo" ~expect:"\004\000\000\000\000\000\000\000\003foo" TEST_UNIT = test Int.bin_writer_t 123 ~expect:"\001\000\000\000\000\000\000\000\123" TEST_UNIT = test (Or_error.bin_writer_t Unit.bin_writer_t) (Or_error.error_string "test") ~expect:"\007\000\000\000\000\000\000\000\001\001\004test" ;; end (* Memory mapping *) let map_file ~shared fd n = Array1.map_file fd Bigarray.char c_layout shared n (* Search *) external unsafe_find : t -> char -> pos:int -> len:int -> int = "bigstring_find" let find ?(pos = 0) ?len chr bstr = let len = get_opt_len bstr ~pos len in check_args ~loc:"find" ~pos ~len bstr; let res = unsafe_find bstr chr ~pos ~len in if res < 0 then None else Some res (* Destruction *) external unsafe_destroy : t -> unit = "bigstring_destroy_stub" (* vim: set filetype=ocaml : *) (* Binary-packing like accessors *) external int32_of_int : int -> int32 = "%int32_of_int" external int32_to_int : int32 -> int = "%int32_to_int" external int64_of_int : int -> int64 = "%int64_of_int" external int64_to_int : int64 -> int = "%int64_to_int" external swap16 : int -> int = "%bswap16" external swap32 : int32 -> int32 = "%bswap_int32" external swap64 : int64 -> int64 = "%bswap_int64" external unsafe_get_16 : t -> int -> int = "%caml_bigstring_get16u" external unsafe_get_32 : t -> int -> int32 = "%caml_bigstring_get32u" external unsafe_get_64 : t -> int -> int64 = "%caml_bigstring_get64u" external unsafe_set_16 : t -> int -> int -> unit = "%caml_bigstring_set16u" external unsafe_set_32 : t -> int -> int32 -> unit = "%caml_bigstring_set32u" external unsafe_set_64 : t -> int -> int64 -> unit = "%caml_bigstring_set64u" let sign_extend_16 u = (u lsl (Core_int.num_bits - 16)) asr (Core_int.num_bits - 16) TEST_UNIT = List.iter [ 0,0 ; 1,1 ; 0x7fff, 32767 ; 0xffff, -1 ; 0x8000, -32768] ~f:(fun (i,expect) -> assert (i >= 0); <:test_result> ~expect (sign_extend_16 i) ) let unsafe_read_int16 t ~pos = sign_extend_16 (unsafe_get_16 t pos) let unsafe_read_int16_swap t ~pos = sign_extend_16 (swap16 (unsafe_get_16 t pos)) let unsafe_write_int16 t ~pos x = unsafe_set_16 t pos x let unsafe_write_int16_swap t ~pos x = unsafe_set_16 t pos (swap16 x) let unsafe_read_uint16 t ~pos = unsafe_get_16 t pos let unsafe_read_uint16_swap t ~pos = swap16 (unsafe_get_16 t pos) let unsafe_write_uint16 t ~pos x = unsafe_set_16 t pos x let unsafe_write_uint16_swap t ~pos x = unsafe_set_16 t pos (swap16 x) let unsafe_read_int32_int t ~pos = int32_to_int (unsafe_get_32 t pos) let unsafe_read_int32_int_swap t ~pos = int32_to_int (swap32 (unsafe_get_32 t pos)) let unsafe_read_int32 t ~pos = unsafe_get_32 t pos let unsafe_read_int32_swap t ~pos = swap32 (unsafe_get_32 t pos) let unsafe_write_int32 t ~pos x = unsafe_set_32 t pos x let unsafe_write_int32_swap t ~pos x = unsafe_set_32 t pos (swap32 x) let unsafe_write_int32_int t ~pos x = unsafe_set_32 t pos (int32_of_int x) let unsafe_write_int32_int_swap t ~pos x = unsafe_set_32 t pos (swap32 (int32_of_int x)) let unsafe_read_int64_int t ~pos = int64_to_int (unsafe_get_64 t pos) let unsafe_read_int64_int_swap t ~pos = int64_to_int (swap64 (unsafe_get_64 t pos)) let unsafe_read_int64 t ~pos = unsafe_get_64 t pos let unsafe_read_int64_swap t ~pos = swap64 (unsafe_get_64 t pos) let unsafe_write_int64 t ~pos x = unsafe_set_64 t pos x let unsafe_write_int64_swap t ~pos x = unsafe_set_64 t pos (swap64 x) let unsafe_write_int64_int t ~pos x = unsafe_set_64 t pos (int64_of_int x) let unsafe_write_int64_int_swap t ~pos x = unsafe_set_64 t pos (swap64 (int64_of_int x)) IFDEF ARCH_BIG_ENDIAN THEN let unsafe_get_int16_be = unsafe_read_int16 let unsafe_get_int16_le = unsafe_read_int16_swap let unsafe_get_uint16_be = unsafe_read_uint16 let unsafe_get_uint16_le = unsafe_read_uint16_swap let unsafe_set_int16_be = unsafe_write_int16 let unsafe_set_int16_le = unsafe_write_int16_swap let unsafe_set_uint16_be = unsafe_write_uint16 let unsafe_set_uint16_le = unsafe_write_uint16_swap let unsafe_get_int32_t_be = unsafe_read_int32 let unsafe_get_int32_t_le = unsafe_read_int32_swap let unsafe_set_int32_t_be = unsafe_write_int32 let unsafe_set_int32_t_le = unsafe_write_int32_swap let unsafe_get_int32_be = unsafe_read_int32_int let unsafe_get_int32_le = unsafe_read_int32_int_swap let unsafe_set_int32_be = unsafe_write_int32_int let unsafe_set_int32_le = unsafe_write_int32_int_swap let unsafe_get_int64_be_trunc = unsafe_read_int64_int let unsafe_get_int64_le_trunc = unsafe_read_int64_int_swap let unsafe_set_int64_be = unsafe_write_int64_int let unsafe_set_int64_le = unsafe_write_int64_int_swap let unsafe_get_int64_t_be = unsafe_read_int64 let unsafe_get_int64_t_le = unsafe_read_int64_swap let unsafe_set_int64_t_be = unsafe_write_int64 let unsafe_set_int64_t_le = unsafe_write_int64_swap ELSE let unsafe_get_int16_be = unsafe_read_int16_swap let unsafe_get_int16_le = unsafe_read_int16 let unsafe_get_uint16_be = unsafe_read_uint16_swap let unsafe_get_uint16_le = unsafe_read_uint16 let unsafe_set_int16_be = unsafe_write_int16_swap let unsafe_set_int16_le = unsafe_write_int16 let unsafe_set_uint16_be = unsafe_write_uint16_swap let unsafe_set_uint16_le = unsafe_write_uint16 let unsafe_get_int32_be = unsafe_read_int32_int_swap let unsafe_get_int32_le = unsafe_read_int32_int let unsafe_set_int32_be = unsafe_write_int32_int_swap let unsafe_set_int32_le = unsafe_write_int32_int let unsafe_get_int32_t_be = unsafe_read_int32_swap let unsafe_get_int32_t_le = unsafe_read_int32 let unsafe_set_int32_t_be = unsafe_write_int32_swap let unsafe_set_int32_t_le = unsafe_write_int32 let unsafe_get_int64_be_trunc = unsafe_read_int64_int_swap let unsafe_get_int64_le_trunc = unsafe_read_int64_int let unsafe_set_int64_be = unsafe_write_int64_int_swap let unsafe_set_int64_le = unsafe_write_int64_int let unsafe_get_int64_t_be = unsafe_read_int64_swap let unsafe_get_int64_t_le = unsafe_read_int64 let unsafe_set_int64_t_be = unsafe_write_int64_swap let unsafe_set_int64_t_le = unsafe_write_int64 ENDIF let int64_conv_error () = failwith "unsafe_read_int64: value cannot be represented unboxed!" ;; IFDEF ARCH_SIXTYFOUR THEN let int64_to_int_exn n = if n >= -0x4000_0000_0000_0000L && n < 0x4000_0000_0000_0000L then int64_to_int n else int64_conv_error () ;; ELSE let int64_to_int_exn n = if n >= -0x0000_0000_4000_0000L && n < 0x0000_0000_4000_0000L then int64_to_int n else int64_conv_error () ;; ENDIF let unsafe_get_int64_be_exn t ~pos = int64_to_int_exn (unsafe_get_int64_t_be t ~pos) let unsafe_get_int64_le_exn t ~pos = int64_to_int_exn (unsafe_get_int64_t_le t ~pos) BENCH_MODULE "unsafe_get_int64_* don't allocate intermediate boxes" = struct let t = init 8 ~f:Char.of_int_exn BENCH "be" = unsafe_get_int64_be_exn t ~pos:0 BENCH "le" = unsafe_get_int64_le_exn t ~pos:0 end let unsafe_set_uint8 t ~pos n = Array1.unsafe_set t pos (Char.unsafe_of_int n) let unsafe_set_int8 t ~pos n = (* in all the set functions where there are these tests, it looks like the test could be removed, since they are only changing the values of the bytes that are not written. *) let n = if n < 0 then n + 256 else n in Array1.unsafe_set t pos (Char.unsafe_of_int n) let unsafe_get_uint8 t ~pos = Char.to_int (Array1.unsafe_get t pos) let unsafe_get_int8 t ~pos = let n = Char.to_int (Array1.unsafe_get t pos) in if n >= 128 then n - 256 else n let unsafe_set_uint32_le t ~pos n = let n = if n >= 1 lsl 31 then n - 1 lsl 32 else n in unsafe_set_int32_le t ~pos n let unsafe_set_uint32_be t ~pos n = let n = if n >= 1 lsl 31 then n - 1 lsl 32 else n in unsafe_set_int32_be t ~pos n let unsafe_get_uint32_le t ~pos = let n = unsafe_get_int32_le t ~pos in if n < 0 then n + 1 lsl 32 else n let unsafe_get_uint32_be t ~pos = let n = unsafe_get_int32_be t ~pos in if n < 0 then n + 1 lsl 32 else n TEST_MODULE "binary accessors" = struct let buf = create 256 let test_accessor ~buf to_str ~fget ~fset vals = Core_list.foldi ~init:true vals ~f:(fun i passing x -> fset buf ~pos:0 x; let y = fget buf ~pos:0 in if x <> y then eprintf "Value %d: expected %s, got %s\n" i (to_str x) (to_str y); x = y && passing) ;; TEST = test_accessor ~buf Int.to_string ~fget:unsafe_get_int16_le ~fset:unsafe_set_int16_le [-32768; -1; 0; 1; 32767] TEST = test_accessor ~buf Int.to_string ~fget:unsafe_get_uint16_le ~fset:unsafe_set_uint16_le [0; 1; 65535] TEST = test_accessor ~buf Int.to_string ~fget:unsafe_get_int16_be ~fset:unsafe_set_int16_be [-32768; -1; 0; 1; 32767] TEST = test_accessor ~buf Int.to_string ~fget:unsafe_get_uint16_be ~fset:unsafe_set_uint16_be [0; 1; 65535] IFDEF ARCH_SIXTYFOUR THEN TEST = test_accessor ~buf Int.to_string ~fget:unsafe_get_int32_le ~fset:unsafe_set_int32_le [Int64.to_int_exn (-2147483648L); -1; 0; 1; Int64.to_int_exn 2147483647L] TEST = test_accessor ~buf Int.to_string ~fget:unsafe_get_int32_be ~fset:unsafe_set_int32_be [Int64.to_int_exn (-2147483648L); -1; 0; 1; Int64.to_int_exn 2147483647L] TEST = test_accessor ~buf Int.to_string ~fget:unsafe_get_int64_le_exn ~fset:unsafe_set_int64_le [Int64.to_int_exn (-2147483648L); -1; 0; 1; Int64.to_int_exn 2147483647L] TEST = test_accessor ~buf Int.to_string ~fget:unsafe_get_int64_be_exn ~fset:unsafe_set_int64_be [Int64.to_int_exn (-0x4000_0000_0000_0000L); Int64.to_int_exn (-2147483648L); -1; 0; 1; Int64.to_int_exn 2147483647L; Int64.to_int_exn 0x3fff_ffff_ffff_ffffL] ENDIF (* ARCH_SIXTYFOUR *) TEST = test_accessor ~buf Int64.to_string ~fget:unsafe_get_int64_t_le ~fset:unsafe_set_int64_t_le [-0x8000_0000_0000_0000L; -0x789A_BCDE_F012_3456L; -0xFFL; Int64.minus_one; Int64.zero; Int64.one; 0x789A_BCDE_F012_3456L; 0x7FFF_FFFF_FFFF_FFFFL] TEST = test_accessor ~buf Int64.to_string ~fget:unsafe_get_int64_t_be ~fset:unsafe_set_int64_t_be [-0x8000_0000_0000_0000L; -0x789A_BCDE_F012_3456L; -0xFFL; Int64.minus_one; Int64.zero; Int64.one; 0x789A_BCDE_F012_3456L; 0x7FFF_FFFF_FFFF_FFFFL] TEST = test_accessor ~buf Int64.to_string ~fget:unsafe_get_int64_t_be ~fset:unsafe_set_int64_t_be [-0x8000_0000_0000_0000L; -0x789A_BCDE_F012_3456L; -0xFFL; Int64.minus_one; Int64.zero; Int64.one; 0x789A_BCDE_F012_3456L; 0x7FFF_FFFF_FFFF_FFFFL] (* Test 63/64-bit precision boundary. Seen on a data stream the constant 0x4000_0000_0000_0000 is supposed to represent a 64-bit positive integer (2^62). Whilst this bit pattern does fit in an OCaml [int] on a 64-bit machine, it is the representation of a negative number ([Int.min_value]), and in particular is not the representation of 2^62. It is thus suitable for this test. *) let test_int64 get_exn get_trunc set_t double_check_set = List.iter [ 0x4000_0000_0000_0000L ; Int64.succ (Int64.of_int Int.max_value) ; Int64.pred (Int64.of_int Int.min_value) ; Int64.min_value ; Int64.max_value ; Int64.succ Int64.min_value ; Int64.pred Int64.max_value ] ~f:(fun too_big -> let trunc = int64_to_int too_big in try set_t buf ~pos:0 too_big; <:test_result< int64 >> ~expect:too_big (double_check_set buf ~pos:0); let test_get name got = <:test_pred< string Or_error.t >> is_error ~message:name (Or_error.map ~f:(fun i -> sprintf "%d = 0x%x" i i) got) in let got_exn = Or_error.try_with (fun () -> get_exn buf ~pos:0) in test_get "get_exn" got_exn; <:test_result< int >> ~message:"get_trunc" ~expect:trunc (get_trunc buf ~pos:0) with e -> failwiths "test_int64" ( sprintf "too_big = %LdL = 0x%LxL" too_big too_big , sprintf "trunc = %d = 0x%x" trunc trunc , e ) <:sexp_of< string * string * exn >>) TEST_UNIT "unsafe_get_int64_le" = test_int64 unsafe_get_int64_le_exn unsafe_get_int64_le_trunc unsafe_set_int64_t_le unsafe_get_int64_t_le TEST_UNIT "unsafe_get_int64_be" = test_int64 unsafe_get_int64_be_exn unsafe_get_int64_be_trunc unsafe_set_int64_t_be unsafe_get_int64_t_be end let rec last_nonmatch_plus_one ~buf ~min_pos ~pos ~char = let pos' = pos - 1 in if pos' >= min_pos && Char.(=) (get buf pos') char then last_nonmatch_plus_one ~buf ~min_pos ~pos:pos' ~char else pos let get_tail_padded_fixed_string ~padding t ~pos ~len () = let data_end = last_nonmatch_plus_one ~buf:t ~min_pos:pos ~pos:(pos + len) ~char:padding in to_string t ~pos ~len:(data_end - pos) let set_tail_padded_fixed_string ~padding t ~pos ~len value = let slen = String.length value in if slen > len then failwithf "Bigstring.set_tail_padded_fixed_string: %S is longer than %d" value len (); From_string.blit ~src:value ~dst:t ~src_pos:0 ~dst_pos:pos ~len:slen; for i = pos + slen to pos + len - 1; do set t i padding done core_kernel-113.00.00/src/bigstring.mli000066400000000000000000000251411256461164500176030ustar00rootroot00000000000000(** String type based on [Bigarray], for use in I/O and C-bindings *) open Bigarray (** {6 Types and exceptions} *) (** Type of bigstrings *) type t = (char, int8_unsigned_elt, c_layout) Array1.t with bin_io, sexp, compare include Equal.S with type t := t (** {6 Creation and string conversion} *) val create : ?max_mem_waiting_gc:Byte_units.t -> int -> t (** [create length] @param max_mem_waiting_gc default = 256 M in OCaml <= 3.12, 1 G otherwise. As the total allocation of calls to [create] approach [max_mem_waiting_gc], the pressure in the garbage collector to be more agressive will increase. @return a new bigstring having [length]. Content is undefined. *) (** [init n ~f] creates a bigstring [t] of length [n], with [t.{i} = f i] *) val init : int -> f:(int -> char) -> t val of_string : ?pos : int -> ?len : int -> string -> t (** [of_string ?pos ?len str] @return a new bigstring that is equivalent to the substring of length [len] in [str] starting at position [pos]. @param pos default = 0 @param len default = [String.length str - pos] *) val to_string : ?pos : int -> ?len : int -> t -> string (** [to_string ?pos ?len bstr] @return a new string that is equivalent to the substring of length [len] in [bstr] starting at position [pos]. @param pos default = 0 @param len default = [length bstr - pos] @raise Invalid_argument if the string would exceed runtime limits. *) (** {6 Checking} *) val check_args : loc : string -> pos : int -> len : int -> t -> unit (** [check_args ~loc ~pos ~len bstr] checks the position and length arguments [pos] and [len] for bigstrings [bstr]. @raise Invalid_argument if these arguments are illegal for the given bigstring using [loc] to indicate the calling context. *) val get_opt_len : t -> pos : int -> int option -> int (** [get_opt_len bstr ~pos opt_len] @return the length of a subbigstring in [bstr] starting at position [pos] and given optional length [opt_len]. This function does not check the validity of its arguments. Use {!check_args} for that purpose. *) (** {6 Accessors} *) val length : t -> int (** [length bstr] @return the length of bigstring [bstr]. *) val sub_shared : ?pos : int -> ?len : int -> t -> t (** [sub_shared ?pos ?len bstr] @return the sub-bigstring in [bstr] that starts at position [pos] and has length [len]. The sub-bigstring shares the same memory region, i.e. modifying it will modify the original bigstring. Holding on to the sub-bigstring will also keep the (usually bigger) original one around. @param pos default = 0 @param len default = [Bigstring.length bstr - pos] *) (** [get t pos] returns the character at [pos] *) external get : t -> int -> char = "%caml_ba_ref_1" (** [set t pos] sets the character at [pos] *) external set : t -> int -> char -> unit = "%caml_ba_set_1" external is_mmapped : t -> bool = "bigstring_is_mmapped_stub" "noalloc" (** [is_mmapped bstr] @return whether the bigstring [bstr] is memory-mapped. *) (** {6 Blitting} *) (** [blit ~src ?src_pos ?src_len ~dst ?dst_pos ()] blits [src_len] characters from [src] starting at position [src_pos] to [dst] at position [dst_pos]. @raise Invalid_argument if the designated ranges are out of bounds. *) include Blit.S with type t := t module To_string : Blit.S_distinct with type src := t with type dst := string module From_string : Blit.S_distinct with type src := string with type dst := t (** {6 Reading/writing bin-prot *) (** These functions write the "size-prefixed" bin-prot format that is used by, e.g., async's [Writer.write_bin_prot], [Reader.read_bin_prot] and [Unpack_buffer.Unpack_one.create_bin_prot]. *) (** [write_bin_prot t writer a] writes [a] to [t] starting at [pos], and returns the index in [t] immediately after the last byte written. It raises if [pos < 0] or if [a] doesn't fit in [t]. *) val write_bin_prot : t -> ?pos:int (** default is 0 *) -> 'a Bin_prot.Type_class.writer -> 'a -> int (** The [read_bin_prot*] functions read from the region of [t] starting at [pos] of length [len]. They return the index in [t] immediately after the last byte read. They raise if [pos] and [len] don't describe a region of [t]. *) val read_bin_prot : t -> ?pos:int -> ?len:int -> 'a Bin_prot.Type_class.reader -> ('a * int) Or_error.t val read_bin_prot_verbose_errors : t -> ?pos:int -> ?len:int -> 'a Bin_prot.Type_class.reader -> [ `Invalid_data of Error.t | `Not_enough_data | `Ok of ('a * int) ] (** {6 Memory mapping} *) val map_file : shared : bool -> Unix.file_descr -> int -> t (** [map_file shared fd n] memory-maps [n] characters of the data associated with descriptor [fd] to a bigstring. Iff [shared] is [true], all changes to the bigstring will be reflected in the file. Users must keep in mind that operations on the resulting bigstring may result in disk operations which block the runtime. This is true for pure OCaml operations (such as t.{1} <- 1), and for calls to [blit]. While some I/O operations may release the OCaml lock, users should not expect this to be done for all operations on a bigstring returned from [map_file]. *) (** {6 Search} *) (** [find ?pos ?len char t] returns [Some i] for the smallest [i >= pos] such that [t.{i} = char], or [None] if there is no such [i]. @param pos default = 0 @param len default = [length bstr - pos] *) val find : ?pos : int -> ?len : int -> char -> t -> int option (** {6 Destruction} *) (** [unsafe_destroy bstr] destroys the bigstring by deallocating its associated data or, if memory-mapped, unmapping the corresponding file, and setting all dimensions to zero. This effectively frees the associated memory or address-space resources instantaneously. This feature helps working around a bug in the current OCaml runtime, which does not correctly estimate how aggressively to reclaim such resources. This operation is safe unless you have passed the bigstring to another thread that is performing operations on it at the same time. Access to the bigstring after this operation will yield array bounds exceptions. @raise Failure if the bigstring has already been deallocated (or deemed "external", which is treated equivalently), or if it has proxies, i.e. other bigstrings referring to the same data. *) external unsafe_destroy : t -> unit = "bigstring_destroy_stub" (** Accessors for parsing binary values, analogous to binary_packing. These are in Bigstring rather than a separate module because: 1) Existing binary_packing requires copies and does not work with bigstrings 2) The accessors rely on the implementation of bigstring, and hence should changeshould the implementation of bigstring move away from Bigarray. 3) Bigstring already has some external C functions, so it didn't require many changes to the OMakefile ^_^. In a departure from Binary_packing, the naming conventions are chosen to be close to C99 stdint types, as it's a more standard description and it is somewhat useful in making compact macros for the implementations. The accessor names contain endian-ness to allow for branch-free implementations ::= ::= unsafe_ | '' ::= get_ | set_ ::= int16 | uint16 | int32 | int64 ::= _le | _be | '' ::= _int | '' The "unsafe_" prefix indicates that these functions do no bounds checking. Performance testing demonstrated that the bounds check was 2-3 times slower due to the fact that Bigstring.length is a C call, and not even a noalloc one. In practice, message parsers can check the size of an outer message once, and use the unsafe accessors for individual fields, so many bounds checks can end up being redundant as well. The situation could be improved by having bigarray cache the length/dimensions. *) val unsafe_get_int8 : t -> pos:int -> int val unsafe_set_int8 : t -> pos:int -> int -> unit val unsafe_get_uint8 : t -> pos:int -> int val unsafe_set_uint8 : t -> pos:int -> int -> unit (** {6 16 bit methods} *) val unsafe_get_int16_le : t -> pos:int -> int val unsafe_get_int16_be : t -> pos:int -> int val unsafe_set_int16_le : t -> pos:int -> int -> unit val unsafe_set_int16_be : t -> pos:int -> int -> unit val unsafe_get_uint16_le : t -> pos:int -> int val unsafe_get_uint16_be : t -> pos:int -> int val unsafe_set_uint16_le : t -> pos:int -> int -> unit val unsafe_set_uint16_be : t -> pos:int -> int -> unit (** {6 32 bit methods} *) val unsafe_get_int32_le : t -> pos:int -> int val unsafe_get_int32_be : t -> pos:int -> int val unsafe_set_int32_le : t -> pos:int -> int -> unit val unsafe_set_int32_be : t -> pos:int -> int -> unit val unsafe_get_uint32_le : t -> pos:int -> int val unsafe_get_uint32_be : t -> pos:int -> int val unsafe_set_uint32_le : t -> pos:int -> int -> unit val unsafe_set_uint32_be : t -> pos:int -> int -> unit (** Similar to the usage in binary_packing, the below methods are treating the value being read (or written), as an ocaml immediate integer, as such it is actually 63 bits. If the user is confident that the range of values used in practice will not require 64 bit precision (i.e. Less than Max_Long), then we can avoid allocation and use an immediate. If the user is wrong, an exception will be thrown (for get). *) val unsafe_get_int64_le_exn : t -> pos:int -> int val unsafe_get_int64_be_exn : t -> pos:int -> int val unsafe_set_int64_le : t -> pos:int -> int -> unit val unsafe_set_int64_be : t -> pos:int -> int -> unit val unsafe_get_int64_le_trunc : t -> pos:int -> int val unsafe_get_int64_be_trunc : t -> pos:int -> int (** {6 32 bit methods w/ full precision} *) val unsafe_get_int32_t_le : t -> pos:int -> Int32.t val unsafe_get_int32_t_be : t -> pos:int -> Int32.t val unsafe_set_int32_t_le : t -> pos:int -> Int32.t -> unit val unsafe_set_int32_t_be : t -> pos:int -> Int32.t -> unit (** {6 64 bit methods w/ full precision} *) val unsafe_get_int64_t_le : t -> pos:int -> Int64.t val unsafe_get_int64_t_be : t -> pos:int -> Int64.t val unsafe_set_int64_t_le : t -> pos:int -> Int64.t -> unit val unsafe_set_int64_t_be : t -> pos:int -> Int64.t -> unit (** similar to [Binary_packing.unpack_tail_padded_fixed_string] and [.pack_tail_padded_fixed_string]. *) val get_tail_padded_fixed_string : padding:char -> t -> pos:int -> len:int -> unit -> string val set_tail_padded_fixed_string : padding:char -> t -> pos:int -> len:int -> string -> unit core_kernel-113.00.00/src/bigstring_marshal.ml000066400000000000000000000042451256461164500211430ustar00rootroot00000000000000open Bigstring (* Marshalling to/from bigstrings *) external unsafe_marshal_blit : 'a -> pos : int -> len : int -> t -> Marshal.extern_flags list -> int = "bigstring_marshal_blit_stub" let marshal_blit ?(flags = []) v ?(pos = 0) ?len bstr = let len = get_opt_len bstr ~pos len in check_args ~loc:"marshal" bstr ~pos ~len; unsafe_marshal_blit v ~pos ~len bstr flags ;; external marshal : 'a -> Marshal.extern_flags list -> t = "bigstring_marshal_stub" let marshal ?(flags = []) x = marshal x flags external unsafe_marshal_data_size : pos : int -> t -> int = "bigstring_marshal_data_size_stub" let marshal_data_size ?(pos = 0) bstr = if pos < 0 || pos > length bstr - Marshal.header_size then invalid_arg "Bigstring.marshal_data_size" else unsafe_marshal_data_size ~pos bstr external unsafe_unmarshal : pos : int -> len : int -> t -> 'a = "bigstring_unmarshal_stub" let unmarshal_next ?pos bstr = let pos = match pos with | None -> 0 | Some pos -> if pos < 0 then invalid_arg "Bigstring.unmarshal: pos < 0" else pos in let len = length bstr in let len_header = len - Marshal.header_size in if pos > len_header then invalid_arg "Bigstring.unmarshal: pos > len - header" else let data_len = unsafe_marshal_data_size ~pos bstr in let block_len = Marshal.header_size + data_len in let next_pos = pos + block_len in if next_pos > len then invalid_arg "Bigstring.unmarshal: pos + block_len > len" else let v = unsafe_unmarshal ~pos ~len:block_len bstr in v, next_pos ;; let unmarshal ?pos bstr = fst (unmarshal_next ?pos bstr) let skip ?pos bstr = let pos = match pos with | None -> 0 | Some pos -> if pos < 0 then invalid_arg "Bigstring.skip: pos < 0" else pos in let len = length bstr in let len_header = len - Marshal.header_size in if pos > len_header then invalid_arg "Bigstring.skip: pos > len - header" else let data_len = unsafe_marshal_data_size ~pos bstr in let block_len = Marshal.header_size + data_len in let next_pos = pos + block_len in if next_pos > len then invalid_arg "Bigstring.skip: pos + block_len > len" else next_pos ;; core_kernel-113.00.00/src/bigstring_marshal.mli000066400000000000000000000021531256461164500213100ustar00rootroot00000000000000(** Utility functions for marshalling to and from bigstring. In all functions below, [pos] is the index into the bigstring to read from or write to and an exception is raised if that index is invalid. The default is 0. *) (** marshals value [_] to the bigstring at most [len] bytes. *) val marshal_blit : ?flags : Marshal.extern_flags list (** default = [] *) -> _ -> ?pos : int -> ?len : int (** default = length buf - pos *) -> Bigstring.t -> int (** marshals value [_] to a new bigstring. This function may need two times more memory than [marshal_blit]. *) val marshal : ?flags : Marshal.extern_flags list (** default = [] *) -> _ -> Bigstring.t (** the length of marshalled data in the bigstring *) val marshal_data_size : ?pos : int -> Bigstring.t -> int (** unmarshals a value from the bigstring and/or returns the index of the byte in the bigstring right after the unmarshalled value. *) val unmarshal : ?pos : int -> Bigstring.t -> _ val unmarshal_next : ?pos : int -> Bigstring.t -> _ * int val skip : ?pos : int -> Bigstring.t -> int core_kernel-113.00.00/src/bigstring_marshal_stubs.c000066400000000000000000000032271256461164500221740ustar00rootroot00000000000000#include #include #include #include #include #include #include #include /* Utility definitions */ static inline char * get_bstr(value v_bstr, value v_pos) { return (char *) Caml_ba_data_val(v_bstr) + Long_val(v_pos); } /* Marshalling to/from bigstrings */ extern CAMLprim int caml_output_value_to_block(value v, value v_flags, char *bstr, int len); CAMLprim value bigstring_marshal_blit_stub( value v, value v_pos, value v_len, value v_bstr, value v_flags) { char *bstr = get_bstr(v_bstr, v_pos); return Val_long(caml_output_value_to_block(v, v_flags, bstr, Long_val(v_len))); } extern CAMLprim void caml_output_value_to_malloc(value v, value v_flags, char **buf_p, long *len); CAMLprim value bigstring_marshal_stub(value v, value v_flags) { char *buf; long len; int alloc_flags = CAML_BA_CHAR | CAML_BA_C_LAYOUT | CAML_BA_MANAGED; caml_output_value_to_malloc(v, v_flags, &buf, &len); return caml_ba_alloc(alloc_flags, 1, buf, &len); } extern CAMLprim value caml_marshal_data_size(value v_str, value v_pos); CAMLprim value bigstring_marshal_data_size_stub(value v_pos, value v_bstr) { CAMLparam1(v_bstr); value v_str = (value) Caml_ba_data_val(v_bstr); value v_res = caml_marshal_data_size(v_str, v_pos); CAMLreturn(v_res); } extern CAMLprim value caml_input_value_from_block(char *buf, int len); CAMLprim value bigstring_unmarshal_stub(value v_pos, value v_len, value v_bstr) { CAMLparam1(v_bstr); char *bstr = get_bstr(v_bstr, v_pos); value v_res = caml_input_value_from_block(bstr, Long_val(v_len)); CAMLreturn(v_res); } core_kernel-113.00.00/src/bigstring_stubs.c000066400000000000000000000124111256461164500204600ustar00rootroot00000000000000#define _FILE_OFFSET_BITS 64 #define _GNU_SOURCE /* recvmmsg */ /* For pread/pwrite */ #define _XOPEN_SOURCE 500 /* For OpenBSD `swap` functions */ #ifdef __OpenBSD__ #define _BSD_SOURCE #endif #include #include #include #include #include #ifdef __APPLE__ #include #define bswap_16 OSSwapInt16 #define bswap_32 OSSwapInt32 #define bswap_64 OSSwapInt64 #elif __GLIBC__ #include #include #elif __OpenBSD__ #include #define bswap_16 swap16 #define bswap_32 swap32 #define bswap_64 swap64 #else #include #include #define __BYTE_ORDER _BYTE_ORDER #define __LITTLE_ENDIAN _LITTLE_ENDIAN #define __BIG_ENDIAN _BIG_ENDIAN #define bswap_16 bswap16 #define bswap_32 bswap32 #define bswap_64 bswap64 #endif #include #include #include #include #include #include "core_params.h" #include "core_bigstring.h" static inline char * get_bstr(value v_bstr, value v_pos) { return (char *) Caml_ba_data_val(v_bstr) + Long_val(v_pos); } CAMLexport value bigstring_alloc (value v_gc_max_unused, value v_size) { intnat size = Long_val (v_size); void * data = NULL; int flags = CORE_BIGSTRING_FLAGS | CAML_BA_MANAGED; intnat gc_max_unused = Long_val(v_gc_max_unused); intnat dims[1]; dims[0] = size; if (gc_max_unused >= 0) { data = (void *) malloc(sizeof(char) * size); if (NULL == data) caml_raise_out_of_memory (); /* caml_adjust_gc_speed is also called by caml_ba_alloc below, but it will have * numerator 0 when data != NULL. Effectively, that call will have no effect if this * call is made. */ caml_adjust_gc_speed(size, gc_max_unused); } return caml_ba_alloc (flags, 1, data, dims); } /* Checking memory-mapping */ CAMLprim value bigstring_is_mmapped_stub(value v_bstr) { return Val_bool((Caml_ba_array_val(v_bstr)->flags & CAML_BA_MAPPED_FILE) != 0); } /* Blitting */ CAMLprim value bigstring_blit_string_bigstring_stub( value v_str, value v_src_pos, value v_bstr, value v_dst_pos, value v_len) { char *str = String_val(v_str) + Long_val(v_src_pos); char *bstr = get_bstr(v_bstr, v_dst_pos); memcpy(bstr, str, Long_val(v_len)); return Val_unit; } CAMLprim value bigstring_blit_bigstring_string_stub( value v_bstr, value v_src_pos, value v_str, value v_dst_pos, value v_len) { char *bstr = get_bstr(v_bstr, v_src_pos); char *str = String_val(v_str) + Long_val(v_dst_pos); memcpy(str, bstr, Long_val(v_len)); return Val_unit; } CAMLprim value bigstring_blit_stub( value v_src, value v_src_pos, value v_dst, value v_dst_pos, value v_len) { struct caml_ba_array *ba_src = Caml_ba_array_val(v_src); struct caml_ba_array *ba_dst = Caml_ba_array_val(v_dst); char *src = (char *) ba_src->data + Long_val(v_src_pos); char *dst = (char *) ba_dst->data + Long_val(v_dst_pos); size_t len = Long_val(v_len); if (len > THREAD_IO_CUTOFF) { Begin_roots2(v_src, v_dst); caml_enter_blocking_section(); memmove(dst, src, Long_val(v_len)); caml_leave_blocking_section(); End_roots(); } else memmove(dst, src, Long_val(v_len)); return Val_unit; } /* Comparison */ CAMLprim value bigstring_memcmp_stub(value v_s1, value v_s1_pos, value v_s2, value v_s2_pos, value v_len) /* noalloc */ { struct caml_ba_array *ba_s1 = Caml_ba_array_val(v_s1); struct caml_ba_array *ba_s2 = Caml_ba_array_val(v_s2); char *s1 = (char *) ba_s1->data + Long_val(v_s1_pos); char *s2 = (char *) ba_s2->data + Long_val(v_s2_pos); int res; res = memcmp(s1, s2, Long_val(v_len)); if (res < 0) return Val_int(-1); if (res > 0) return Val_int(1); return Val_int(0); } /* Search */ CAMLprim value bigstring_find(value v_str, value v_needle, value v_pos, value v_len) { char *start, *r; long ret; start = get_bstr(v_str, v_pos); r = (char*) memchr(start, Int_val(v_needle), Long_val(v_len)); if (!r) return Val_long(-1); ret = Long_val(v_pos) + r - start; return Val_long(ret); } /* Destruction */ static void check_bigstring_proxy(struct caml_ba_array *b) { if (b->proxy != NULL) caml_failwith("bigstring_destroy: bigstring has proxy"); } extern void caml_ba_unmap_file(void *addr, uintnat len); void core_bigstring_destroy(struct caml_ba_array *b, int flags) { int i; switch (b->flags & CAML_BA_MANAGED_MASK) { case CAML_BA_EXTERNAL : if ((flags & CORE_BIGSTRING_DESTROY_ALLOW_EXTERNAL) != CORE_BIGSTRING_DESTROY_ALLOW_EXTERNAL) caml_failwith("bigstring_destroy: bigstring is external or already deallocated"); break; case CAML_BA_MANAGED : check_bigstring_proxy(b); free(b->data); break; case CAML_BA_MAPPED_FILE : check_bigstring_proxy(b); if ((flags & CORE_BIGSTRING_DESTROY_DO_NOT_UNMAP) != CORE_BIGSTRING_DESTROY_DO_NOT_UNMAP) caml_ba_unmap_file(b->data, caml_ba_byte_size(b)); break; } b->data = NULL; b->flags = CAML_BA_EXTERNAL; for (i = 0; i < b->num_dims; ++i) b->dim[i] = 0; } CAMLprim value bigstring_destroy_stub(value v_bstr) { core_bigstring_destroy(Caml_ba_array_val(v_bstr), 0); return Val_unit; } core_kernel-113.00.00/src/bigsubstring.ml000066400000000000000000000007501256461164500201430ustar00rootroot00000000000000include Make_substring.F (struct type t = Bigstring.t let create = Bigstring.create ?max_mem_waiting_gc:None let length = Bigstring.length module Blit = Make_substring.Blit let blit = Blit.bigstring_bigstring let blit_to_string = Blit.bigstring_string let blit_to_bigstring = Blit.bigstring_bigstring let blit_from_string = Blit.string_bigstring let blit_from_bigstring = Blit.bigstring_bigstring let of_bigstring t = t let of_string s = Bigstring.of_string s end) core_kernel-113.00.00/src/bigsubstring.mli000066400000000000000000000002001256461164500203020ustar00rootroot00000000000000(** Substring type based on [Bigarray], for use in I/O and C-bindings *) include Make_substring.S with type base = Bigstring.t core_kernel-113.00.00/src/binable.ml000066400000000000000000000015171256461164500170370ustar00rootroot00000000000000open Bin_prot.Std open Sexplib.Std include Binable0 (* [of_string] and [to_string] can't go in binable0.ml due to a cyclic dependency. *) let of_string m string = of_bigstring m (Bigstring.of_string string) let to_string m t = Bigstring.to_string (to_bigstring m t) TEST_UNIT = let module M = struct type t = int with bin_io end in let m = (module M : S with type t = int) in List.iter [ min_int; min_int / 2; -1; 0; 1; max_int / 2; max_int; ] ~f:(fun i -> let check name of_x to_x = let i' = of_x m (to_x m i) in if i <> i' then Error.failwiths (Printf.sprintf "Binable.{of,to}_%s failure" name) (i, `Round_tripped_to i') <:sexp_of< int * [ `Round_tripped_to of int ] >> in check "string" of_string to_string; check "bigstring" of_bigstring to_bigstring; ) ;; core_kernel-113.00.00/src/binable.mli000066400000000000000000000026671256461164500172170ustar00rootroot00000000000000(** Module types and utilities for dealing with types that support the bin-io binary encoding. *) open Bin_prot.Binable open Bigarray (* We copy the definition of the bigstring type here, because we cannot depend on bigstring.ml *) type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t module type S = S module type S1 = S1 module type S2 = S2 (** [Of_binable*] functors are for when you want the binary representation of one type to be the same as that for some other isomorphic type. *) module Of_binable (Binable : S) (M : sig type t val to_binable : t -> Binable.t val of_binable : Binable.t -> t end) : S with type t := M.t module Of_binable1 (Binable : S1) (M : sig type 'a t val to_binable : 'a t -> 'a Binable.t val of_binable : 'a Binable.t -> 'a t end) : S1 with type 'a t := 'a M.t module Of_binable2 (Binable : S2) (M : sig type ('a, 'b) t val to_binable : ('a, 'b) t -> ('a, 'b) Binable.t val of_binable : ('a, 'b) Binable.t -> ('a, 'b) t end) : S2 with type ('a, 'b) t := ('a, 'b) M.t module Of_stringable (M : Stringable.S) : S with type t := M.t type 'a m = (module S with type t = 'a) val of_bigstring : 'a m -> bigstring -> 'a val to_bigstring : ?prefix_with_length:bool (** defaults to false *) -> 'a m -> 'a -> bigstring val of_string : 'a m -> string -> 'a val to_string : 'a m -> 'a -> string core_kernel-113.00.00/src/binable0.ml000066400000000000000000000046111256461164500171150ustar00rootroot00000000000000include Bin_prot.Binable open Sexplib.Std open Bin_prot.Std module List = ListLabels module Of_stringable (M : Stringable.S) = Bin_prot.Utils.Make_binable (struct module Binable = struct type t = string with bin_io end type t = M.t let to_binable = M.to_string (* Wrap exception for improved diagnostics. *) exception Of_binable of string * exn with sexp let of_binable s = try M.of_string s with x -> raise (Of_binable (s, x)) end) open Bigarray type bigstring = (char, int8_unsigned_elt, c_layout) Array1.t type 'a m = (module S with type t = 'a) let of_bigstring (type a) m bigstring = let module M = (val m : S with type t = a) in let pos_ref = ref 0 in let t = M.bin_read_t bigstring ~pos_ref in assert (!pos_ref = Array1.dim bigstring); t ;; (* Using the [Bigstring] module would introduce a cyclic dependency. *) let create_bigstring size = Array1.create Bigarray.char Bigarray.c_layout size let to_bigstring ?(prefix_with_length = false) (type a) m t = let module M = (val m : S with type t = a) in let t_length = M.bin_size_t t in let bigstring_length = if prefix_with_length then t_length + 8 (* the size of a 64-bit int *) else t_length in let bigstring = create_bigstring bigstring_length in let pos = if prefix_with_length then Bin_prot.Write.bin_write_int_64bit bigstring ~pos:0 t_length else 0 in let pos = M.bin_write_t bigstring ~pos t in assert (pos = bigstring_length); bigstring ;; module Of_binable (Binable : S) (M : sig type t val to_binable : t -> Binable.t val of_binable : Binable.t -> t end) : S with type t := M.t = Bin_prot.Utils.Make_binable (struct module Binable = Binable include M end) module Of_binable1 (Binable : S1) (M : sig type 'a t val to_binable : 'a t -> 'a Binable.t val of_binable : 'a Binable.t -> 'a t end) : S1 with type 'a t := 'a M.t = Bin_prot.Utils.Make_binable1 (struct module Binable = Binable include M end) module Of_binable2 (Binable : S2) (M : sig type ('a, 'b) t val to_binable : ('a, 'b) t -> ('a, 'b) Binable.t val of_binable : ('a, 'b) Binable.t -> ('a, 'b) t end) : S2 with type ('a, 'b) t := ('a, 'b) M.t = Bin_prot.Utils.Make_binable2 (struct module Binable = Binable include M end) core_kernel-113.00.00/src/binary_packing.ml000066400000000000000000001031231256461164500204170ustar00rootroot00000000000000open Std_internal module Char = Caml.Char module Int32 = Caml.Int32 module Int64 = Caml.Int64 INCLUDE "config.mlh" IFDEF ARCH_SIXTYFOUR THEN let signed_max = Int32.to_int Int32.max_int let unsigned_max = Int64.to_int 0xffff_ffffL ENDIF type endian = [ `Big_endian | `Little_endian ] (* Computes the offset based on the total number of bytes, the byte order, and the byte number. The byte number is ordered by decreasing significance starting at zero (big endian). So the most significant byte is 0, and the least significant byte is (len - 1). *) exception Binary_packing_invalid_byte_number of int * int with sexp let offset ~len ~byte_order byte_nr = if byte_nr >= len || byte_nr < 0 then raise (Binary_packing_invalid_byte_number (byte_nr, len)); match byte_order with | `Little_endian -> len - 1 - byte_nr | `Big_endian -> byte_nr ;; (* byte order added to the _8 functions to make testing easier (uniformity) *) exception Pack_unsigned_8_argument_out_of_range of int with sexp let pack_unsigned_8 ~buf ~pos n = if n > 0xFF || n < 0 then raise (Pack_unsigned_8_argument_out_of_range n) else buf.[pos] <- Char.unsafe_chr n; ;; let unpack_unsigned_8 ~buf ~pos = Char.code buf.[pos] exception Pack_signed_8_argument_out_of_range of int with sexp let pack_signed_8 ~buf ~pos n = if n > 0x7F || n < -0x80 then raise (Pack_signed_8_argument_out_of_range n) else buf.[pos] <- Char.unsafe_chr n ;; let unpack_signed_8 ~buf ~pos = let n = unpack_unsigned_8 ~buf ~pos in if n >= 0x80 then -(0x100 - n) else n ;; exception Pack_unsigned_16_argument_out_of_range of int with sexp let pack_unsigned_16 ~byte_order ~buf ~pos n = if n >= 0x10000 || n < 0 then raise (Pack_unsigned_16_argument_out_of_range n) else begin buf.[pos + offset ~len:2 ~byte_order 0] <- Char.unsafe_chr (0xFF land (n asr 8)); buf.[pos + offset ~len:2 ~byte_order 1] <- Char.unsafe_chr (0xFF land n) end ;; let pack_unsigned_16_big_endian ~buf ~pos n = if n >= 0x10000 || n < 0 then raise (Pack_unsigned_16_argument_out_of_range n) else begin buf.[pos ] <- Char.unsafe_chr (0xFF land (n lsr 8)); buf.[pos + 1] <- Char.unsafe_chr (0xFF land n) end ;; let pack_unsigned_16_little_endian ~buf ~pos n = if n >= 0x10000 || n < 0 then raise (Pack_unsigned_16_argument_out_of_range n) else begin buf.[pos + 1] <- Char.unsafe_chr (0xFF land (n lsr 8)); buf.[pos ] <- Char.unsafe_chr (0xFF land n) end ;; exception Pack_signed_16_argument_out_of_range of int with sexp let pack_signed_16 ~byte_order ~buf ~pos n = if n > 0x7FFF || n < -0x8000 then raise (Pack_signed_16_argument_out_of_range n) else begin buf.[pos + offset ~len:2 ~byte_order 0] <- Char.unsafe_chr (0xFF land (n asr 8)); buf.[pos + offset ~len:2 ~byte_order 1] <- Char.unsafe_chr (0xFF land n) end ;; let pack_signed_16_big_endian ~buf ~pos n = if n > 0x7FFF || n < -0x8000 then raise (Pack_signed_16_argument_out_of_range n) else begin buf.[pos ] <- Char.unsafe_chr (0xFF land (n asr 8)); buf.[pos + 1] <- Char.unsafe_chr (0xFF land n) end ;; let pack_signed_16_little_endian ~buf ~pos n = if n > 0x7FFF || n < -0x8000 then raise (Pack_signed_16_argument_out_of_range n) else begin buf.[pos + 1] <- Char.unsafe_chr (0xFF land (n asr 8)); buf.[pos ] <- Char.unsafe_chr (0xFF land n) end ;; let unpack_unsigned_16 ~byte_order ~buf ~pos = let b1 = Char.code buf.[pos + offset ~len:2 ~byte_order 0] lsl 8 in let b2 = Char.code buf.[pos + offset ~len:2 ~byte_order 1] in b1 lor b2 ;; let unpack_signed_16 ~byte_order ~buf ~pos = let n = unpack_unsigned_16 ~byte_order ~buf ~pos in if n >= 0x8000 then -(0x10000 - n) else n ;; let unpack_unsigned_16_big_endian ~buf ~pos = let b1 = Char.code buf.[pos ] lsl 8 in let b2 = Char.code buf.[pos + 1] in b1 lor b2 ;; let unpack_unsigned_16_little_endian ~buf ~pos = let b1 = Char.code buf.[pos + 1] lsl 8 in let b2 = Char.code buf.[pos ] in b1 lor b2 ;; let unpack_signed_16_big_endian ~buf ~pos = let n = unpack_unsigned_16_big_endian ~buf ~pos in if n >= 0x8000 then -(0x10000 - n) else n ;; let unpack_signed_16_little_endian ~buf ~pos = let n = unpack_unsigned_16_little_endian ~buf ~pos in if n >= 0x8000 then -(0x10000 - n) else n ;; module Make_inline_tests (A: sig val num_bytes: int val signed: bool type t val ns: t list val of_int64: int64 -> t val to_int64: t -> int64 val pack: byte_order:endian -> buf:string -> pos:int -> t -> unit val unpack: byte_order:endian -> buf:string -> pos:int -> t val pack_big_endian: buf:string -> pos:int -> t -> unit val unpack_big_endian: buf:string -> pos:int -> t val pack_little_endian: buf:string -> pos:int -> t -> unit val unpack_little_endian: buf:string -> pos:int -> t end) = struct include A let pos = 3 let buf_size = 13 let ns_rev = List.map ns ~f:(fun t -> let t = to_int64 t in of_int64 ( List.fold ~init:0L (List.init num_bytes ~f:Fn.id) ~f:(fun acc k -> Int64.logor acc ( let w = Int64.shift_left (Int64.logand 0xFFL (Int64.shift_right_logical t (k * 8))) ((num_bytes - 1 - k) * 8) in if signed && num_bytes < 8 then let max_val = Int64.shift_left 1L (num_bytes * 8 - 1) in if w >= max_val then Int64.sub w (Int64.shift_left max_val 1) else w else w)))) let padding = '.' let test_rest_of_buf buf = for k = 0 to buf_size - 1 do if k < pos || k > pos + num_bytes then assert (String.get buf k = padding) done ;; TEST = ns = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack ~byte_order:`Little_endian ~buf ~pos n; test_rest_of_buf buf; unpack ~byte_order:`Little_endian ~buf ~pos) TEST = ns = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack ~byte_order:`Big_endian ~buf ~pos n; test_rest_of_buf buf; unpack ~byte_order:`Big_endian ~buf ~pos) TEST = ns = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack_little_endian ~buf ~pos n; test_rest_of_buf buf; unpack_little_endian ~buf ~pos) TEST = ns = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack_big_endian ~buf ~pos n; test_rest_of_buf buf; unpack_big_endian ~buf ~pos) TEST = ns_rev = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack_big_endian ~buf ~pos n; test_rest_of_buf buf; unpack_little_endian ~buf ~pos) TEST = ns_rev = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack_little_endian ~buf ~pos n; test_rest_of_buf buf; unpack_big_endian ~buf ~pos) TEST = ns = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack ~byte_order:`Big_endian ~buf ~pos n; test_rest_of_buf buf; unpack_big_endian ~buf ~pos) TEST = ns = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack ~byte_order:`Little_endian ~buf ~pos n; test_rest_of_buf buf; unpack_little_endian ~buf ~pos) TEST = ns = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack_big_endian ~buf ~pos n; test_rest_of_buf buf; unpack ~byte_order:`Big_endian ~buf ~pos) TEST = ns = List.map ns ~f:(fun n -> let buf = String.make buf_size padding in pack_little_endian ~buf ~pos n; test_rest_of_buf buf; unpack ~byte_order:`Little_endian ~buf ~pos) end TEST_MODULE "inline_unsigned_16" = Make_inline_tests (struct let ns = [0x3f20; 0x7f20; 0xef20; 0; 0x7fff; 0x8000; 0xffff] let num_bytes = 2 let signed = false type t = int let of_int64 = Int64.to_int let to_int64 = Int64.of_int let pack = pack_unsigned_16 let unpack = unpack_unsigned_16 let pack_big_endian = pack_unsigned_16_big_endian let unpack_big_endian = unpack_unsigned_16_big_endian let pack_little_endian = pack_unsigned_16_little_endian let unpack_little_endian = unpack_unsigned_16_little_endian end) TEST_MODULE "inline_signed_16" = Make_inline_tests (struct let ns = [0x3f20; 0x7f20; -0x7f20; -0x8000; 0; 1; 0x7fff] let num_bytes = 2 let signed = true type t = int let of_int64 = Int64.to_int let to_int64 = Int64.of_int let pack = pack_signed_16 let unpack = unpack_signed_16 let pack_big_endian = pack_signed_16_big_endian let unpack_big_endian = unpack_signed_16_big_endian let pack_little_endian = pack_signed_16_little_endian let unpack_little_endian = unpack_signed_16_little_endian end) exception Pack_unsigned_32_argument_out_of_range of int with sexp let check_unsigned_32_in_range n = IFDEF ARCH_SIXTYFOUR THEN if n > unsigned_max || n < 0 then raise (Pack_unsigned_32_argument_out_of_range n) ELSE if n < 0 then raise (Pack_unsigned_32_argument_out_of_range n) ENDIF let pack_unsigned_32_int ~byte_order ~buf ~pos n = assert (Sys.word_size = 64); check_unsigned_32_in_range n; buf.[pos + offset ~len:4 ~byte_order 0] <- Char.unsafe_chr (0xFF land (n asr 24)); (* MSB *) buf.[pos + offset ~len:4 ~byte_order 1] <- Char.unsafe_chr (0xFF land (n asr 16)); buf.[pos + offset ~len:4 ~byte_order 2] <- Char.unsafe_chr (0xFF land (n asr 8)); buf.[pos + offset ~len:4 ~byte_order 3] <- Char.unsafe_chr (0xFF land n) (* LSB *) ;; let pack_unsigned_32_int_big_endian ~buf ~pos n = check_unsigned_32_in_range n; buf.[pos] <- Char.unsafe_chr (0xFF land (n lsr 24)); (* MSB *) buf.[pos + 3] <- Char.unsafe_chr (0xFF land n); (* LSB *) Caml.String.unsafe_set buf (pos + 1) (Char.unsafe_chr (0xFF land (n lsr 16))); Caml.String.unsafe_set buf (pos + 2) (Char.unsafe_chr (0xFF land (n lsr 8))); ;; let pack_unsigned_32_int_little_endian ~buf ~pos n = check_unsigned_32_in_range n; buf.[pos + 3] <- Char.unsafe_chr (0xFF land (n lsr 24)); (* MSB *) buf.[pos] <- Char.unsafe_chr (0xFF land n); (* LSB *) Caml.String.unsafe_set buf (pos + 2) (Char.unsafe_chr (0xFF land (n lsr 16))); Caml.String.unsafe_set buf (pos + 1) (Char.unsafe_chr (0xFF land (n lsr 8))); ;; exception Pack_signed_32_argument_out_of_range of int with sexp let check_signed_32_in_range n = IFDEF ARCH_SIXTYFOUR THEN if n > signed_max || n < -(signed_max + 1) then raise (Pack_signed_32_argument_out_of_range n) ELSE if false then raise (Pack_signed_32_argument_out_of_range n) ENDIF let pack_signed_32_int ~byte_order ~buf ~pos n = assert (Sys.word_size = 64); check_signed_32_in_range n; buf.[pos + offset ~len:4 ~byte_order 0] <- Char.unsafe_chr (0xFF land (n asr 24)); (* MSB *) buf.[pos + offset ~len:4 ~byte_order 1] <- Char.unsafe_chr (0xFF land (n asr 16)); buf.[pos + offset ~len:4 ~byte_order 2] <- Char.unsafe_chr (0xFF land (n asr 8)); buf.[pos + offset ~len:4 ~byte_order 3] <- Char.unsafe_chr (0xFF land n) (* LSB *) ;; let pack_signed_32_int_big_endian ~buf ~pos n = check_signed_32_in_range n; buf.[pos] <- Char.unsafe_chr (0xFF land (n asr 24)); (* MSB *) buf.[pos + 3] <- Char.unsafe_chr (0xFF land n); (* LSB *) Caml.String.unsafe_set buf (pos + 1) (Char.unsafe_chr (0xFF land (n asr 16))); Caml.String.unsafe_set buf (pos + 2) (Char.unsafe_chr (0xFF land (n asr 8))); ;; let pack_signed_32_int_little_endian ~buf ~pos n = check_signed_32_in_range n; buf.[pos + 3] <- Char.unsafe_chr (0xFF land (n asr 24)); (* MSB *) buf.[pos] <- Char.unsafe_chr (0xFF land n); (* LSB *) Caml.String.unsafe_set buf (pos + 2) (Char.unsafe_chr (0xFF land (n asr 16))); Caml.String.unsafe_set buf (pos + 1) (Char.unsafe_chr (0xFF land (n asr 8))); ;; let pack_signed_32 ~byte_order ~buf ~pos n = buf.[pos + offset ~len:4 ~byte_order 0] <- Char.unsafe_chr (0xFF land Int32.to_int (Int32.shift_right n 24)); buf.[pos + offset ~len:4 ~byte_order 1] <- Char.unsafe_chr (0xFF land Int32.to_int (Int32.shift_right n 16)); buf.[pos + offset ~len:4 ~byte_order 2] <- Char.unsafe_chr (0xFF land Int32.to_int (Int32.shift_right n 8)); buf.[pos + offset ~len:4 ~byte_order 3] <- Char.unsafe_chr (0xFF land Int32.to_int n) ;; let unpack_signed_32 ~byte_order ~buf ~pos = let b1 = (* MSB *) Int32.shift_left (Int32.of_int (Char.code buf.[pos + offset ~len:4 ~byte_order 0])) 24 in let b2 = Char.code buf.[pos + offset ~len:4 ~byte_order 1] lsl 16 in let b3 = Char.code buf.[pos + offset ~len:4 ~byte_order 2] lsl 8 in let b4 = Char.code buf.[pos + offset ~len:4 ~byte_order 3] in (* LSB *) Int32.logor b1 (Int32.of_int (b2 lor b3 lor b4)) ;; let unpack_unsigned_32_int ~byte_order ~buf ~pos = assert (Sys.word_size = 64); let b1 = Char.code buf.[pos + offset ~len:4 ~byte_order 0] lsl 24 in (* msb *) let b2 = Char.code buf.[pos + offset ~len:4 ~byte_order 1] lsl 16 in let b3 = Char.code buf.[pos + offset ~len:4 ~byte_order 2] lsl 8 in let b4 = Char.code buf.[pos + offset ~len:4 ~byte_order 3] in (* lsb *) b1 lor b2 lor b3 lor b4 ;; let unpack_unsigned_32_int_big_endian ~buf ~pos = let b1 = Char.code buf.[pos] lsl 24 in (* msb *) let b4 = Char.code buf.[pos + 3] in (* lsb *) let b2 = Char.code (Caml.String.unsafe_get buf (pos + 1)) lsl 16 in let b3 = Char.code (Caml.String.unsafe_get buf (pos + 2)) lsl 8 in b1 lor b2 lor b3 lor b4 ;; let unpack_unsigned_32_int_little_endian ~buf ~pos = let b1 = Char.code buf.[pos + 3] lsl 24 in (* msb *) let b4 = Char.code buf.[pos] in (* lsb *) let b2 = Char.code (Caml.String.unsafe_get buf (pos + 2)) lsl 16 in let b3 = Char.code (Caml.String.unsafe_get buf (pos + 1)) lsl 8 in b1 lor b2 lor b3 lor b4 ;; IFDEF ARCH_SIXTYFOUR THEN let unpack_signed_32_int ~byte_order ~buf ~pos = let n = unpack_unsigned_32_int ~byte_order ~buf ~pos in if n > signed_max then -(((signed_max + 1) lsl 1) - n) else n ;; let unpack_signed_32_int_big_endian ~buf ~pos = let n = unpack_unsigned_32_int_big_endian ~buf ~pos in if n > signed_max then n - (unsigned_max + 1) else n ;; let unpack_signed_32_int_little_endian ~buf ~pos = let n = unpack_unsigned_32_int_little_endian ~buf ~pos in if n > signed_max then n - (unsigned_max + 1) else n ;; TEST_MODULE "inline_unsigned_32_int" = Make_inline_tests (struct let ns = [0x3f20_3040; 0x7f20_3040; signed_max; signed_max + 1; unsigned_max; 0] let num_bytes = 4 let signed = false type t = int let of_int64 = Int64.to_int let to_int64 = Int64.of_int let pack = pack_unsigned_32_int let unpack = unpack_unsigned_32_int let pack_big_endian = pack_unsigned_32_int_big_endian let unpack_big_endian = unpack_unsigned_32_int_big_endian let pack_little_endian = pack_unsigned_32_int_little_endian let unpack_little_endian = unpack_unsigned_32_int_little_endian end) TEST_MODULE "inline_signed_32_int" = Make_inline_tests (struct let ns = [0x3f20_3040; 0x7f20_3040; -0x7f20_3040; signed_max; -(signed_max + 1); 0] let num_bytes = 4 let signed = true type t = int let of_int64 = Int64.to_int let to_int64 = Int64.of_int let pack = pack_signed_32_int let unpack = unpack_signed_32_int let pack_big_endian = pack_signed_32_int_big_endian let unpack_big_endian = unpack_signed_32_int_big_endian let pack_little_endian = pack_signed_32_int_little_endian let unpack_little_endian = unpack_signed_32_int_little_endian end) ELSE let unpack_signed_32_int = unpack_unsigned_32_int let unpack_signed_32_int_big_endian = unpack_unsigned_32_int_big_endian let unpack_signed_32_int_little_endian = unpack_unsigned_32_int_little_endian ENDIF (* ARCH_SIXTYFOUR *) let pack_signed_64 ~byte_order ~buf ~pos v = let top3 = Int64.to_int (Int64.shift_right v 40) in let mid3 = Int64.to_int (Int64.shift_right v 16) in let bot2 = Int64.to_int v in buf.[pos + offset ~len:8 ~byte_order 0] <- Char.unsafe_chr (0xFF land (top3 lsr 16)); buf.[pos + offset ~len:8 ~byte_order 1] <- Char.unsafe_chr (0xFF land (top3 lsr 8)); buf.[pos + offset ~len:8 ~byte_order 2] <- Char.unsafe_chr (0xFF land top3); buf.[pos + offset ~len:8 ~byte_order 3] <- Char.unsafe_chr (0xFF land (mid3 lsr 16)); buf.[pos + offset ~len:8 ~byte_order 4] <- Char.unsafe_chr (0xFF land (mid3 lsr 8)); buf.[pos + offset ~len:8 ~byte_order 5] <- Char.unsafe_chr (0xFF land mid3); buf.[pos + offset ~len:8 ~byte_order 6] <- Char.unsafe_chr (0xFF land (bot2 lsr 8)); buf.[pos + offset ~len:8 ~byte_order 7] <- Char.unsafe_chr (0xFF land bot2) ;; let pack_signed_64_big_endian ~buf ~pos v = (* Safely set the first and last bytes, so that we verify the string bounds. *) buf.[pos] <- Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 56))); buf.[pos + 7] <- Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL v)); (* Now we can use [unsafe_set] for the intermediate bytes. *) Caml.String.unsafe_set buf (pos + 1) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 48)))); Caml.String.unsafe_set buf (pos + 2) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 40)))); Caml.String.unsafe_set buf (pos + 3) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 32)))); Caml.String.unsafe_set buf (pos + 4) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 24)))); Caml.String.unsafe_set buf (pos + 5) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 16)))); Caml.String.unsafe_set buf (pos + 6) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 8)))) ;; let pack_signed_64_little_endian ~buf ~pos v = (* Safely set the first and last bytes, so that we verify the string bounds. *) buf.[pos] <- Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL v)); buf.[pos + 7] <- Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 56))); (* Now we can use [unsafe_set] for the intermediate bytes. *) Caml.String.unsafe_set buf (pos + 1) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 8)))); Caml.String.unsafe_set buf (pos + 2) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 16)))); Caml.String.unsafe_set buf (pos + 3) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 24)))); Caml.String.unsafe_set buf (pos + 4) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 32)))); Caml.String.unsafe_set buf (pos + 5) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 40)))); Caml.String.unsafe_set buf (pos + 6) (Char.unsafe_chr (Int64.to_int (Int64.logand 0xFFL (Int64.shift_right_logical v 48)))) ;; let unpack_signed_64 ~byte_order ~buf ~pos = Int64.logor (Int64.logor (Int64.shift_left (Int64.of_int (Char.code buf.[pos + offset ~len:8 ~byte_order 0] lsl 16 lor Char.code buf.[pos + offset ~len:8 ~byte_order 1] lsl 8 lor Char.code buf.[pos + offset ~len:8 ~byte_order 2])) 40) (Int64.shift_left (Int64.of_int (Char.code buf.[pos + offset ~len:8 ~byte_order 3] lsl 16 lor Char.code buf.[pos + offset ~len:8 ~byte_order 4] lsl 8 lor Char.code buf.[pos + offset ~len:8 ~byte_order 5])) 16)) (Int64.of_int (Char.code buf.[pos + offset ~len:8 ~byte_order 6] lsl 8 lor Char.code buf.[pos + offset ~len:8 ~byte_order 7])) ;; let unpack_signed_64_big_endian ~buf ~pos = (* Do bounds checking only on the first and last bytes *) let b1 = Char.code buf.[pos] and b8 = Char.code buf.[pos + 7] in let b2 = Char.code (Caml.String.unsafe_get buf (pos + 1)) and b3 = Char.code (Caml.String.unsafe_get buf (pos + 2)) and b4 = Char.code (Caml.String.unsafe_get buf (pos + 3)) and b5 = Char.code (Caml.String.unsafe_get buf (pos + 4)) and b6 = Char.code (Caml.String.unsafe_get buf (pos + 5)) and b7 = Char.code (Caml.String.unsafe_get buf (pos + 6)) in IFDEF ARCH_SIXTYFOUR THEN let i1 = Int64.of_int ( b1) and i2 = Int64.of_int ((b2 lsl 48) lor (b3 lsl 40) lor (b4 lsl 32) lor (b5 lsl 24) lor (b6 lsl 16) lor (b7 lsl 8) lor b8) in Int64.(logor i2 (shift_left i1 56)) ELSE let i1 = Int64.of_int ( (b1 lsl 8) lor b2) and i2 = Int64.of_int ((b3 lsl 16) lor (b4 lsl 8) lor b5) and i3 = Int64.of_int ((b6 lsl 16) lor (b7 lsl 8) lor b8) in Int64.(logor i3 (logor (shift_left i2 24) (shift_left i1 48))) ENDIF ;; let unpack_signed_64_little_endian ~buf ~pos = (* Do bounds checking only on the first and last bytes *) let b1 = Char.code buf.[pos] and b8 = Char.code buf.[pos + 7] in let b2 = Char.code (Caml.String.unsafe_get buf (pos + 1)) and b3 = Char.code (Caml.String.unsafe_get buf (pos + 2)) and b4 = Char.code (Caml.String.unsafe_get buf (pos + 3)) and b5 = Char.code (Caml.String.unsafe_get buf (pos + 4)) and b6 = Char.code (Caml.String.unsafe_get buf (pos + 5)) and b7 = Char.code (Caml.String.unsafe_get buf (pos + 6)) in IFDEF ARCH_SIXTYFOUR THEN let i1 = Int64.of_int ( b1 lor (b2 lsl 8) lor (b3 lsl 16) lor (b4 lsl 24) lor (b5 lsl 32) lor (b6 lsl 40) lor (b7 lsl 48)) and i2 = Int64.of_int b8 in Int64.(logor i1 (shift_left i2 56)) ELSE let i1 = Int64.of_int (b1 lor (b2 lsl 8) lor (b3 lsl 16)) and i2 = Int64.of_int (b4 lor (b5 lsl 8) lor (b6 lsl 16)) and i3 = Int64.of_int (b7 lor (b8 lsl 8)) in Int64.(logor i1 (logor (shift_left i2 24) (shift_left i3 48))) ENDIF ;; let pack_signed_64_int ~byte_order ~buf ~pos n = assert (Sys.word_size = 64); buf.[pos + offset ~len:8 ~byte_order 0] <- Char.unsafe_chr (0xFF land (n asr 56)); buf.[pos + offset ~len:8 ~byte_order 1] <- Char.unsafe_chr (0xFF land (n asr 48)); buf.[pos + offset ~len:8 ~byte_order 2] <- Char.unsafe_chr (0xFF land (n asr 40)); buf.[pos + offset ~len:8 ~byte_order 3] <- Char.unsafe_chr (0xFF land (n asr 32)); buf.[pos + offset ~len:8 ~byte_order 4] <- Char.unsafe_chr (0xFF land (n asr 24)); buf.[pos + offset ~len:8 ~byte_order 5] <- Char.unsafe_chr (0xFF land (n asr 16)); buf.[pos + offset ~len:8 ~byte_order 6] <- Char.unsafe_chr (0xFF land (n asr 8)); buf.[pos + offset ~len:8 ~byte_order 7] <- Char.unsafe_chr (0xFF land n) ;; (* It's important to use [asr] not [lsr] in [pack_signed_64_int_big_endian] and [pack_signed_64_int_little_endian] so that the most significant byte is encoded correctly. (It might be helpful to think about this as widening, i.e. sign extending, the number to 64 bits and then doing the right shift by 56.) *) let pack_signed_64_int_big_endian ~buf ~pos v = (* Safely set the first and last bytes, so that we verify the string bounds. *) buf.[pos] <- Char.unsafe_chr (0xFF land (v asr 56)); buf.[pos + 7] <- Char.unsafe_chr (0xFF land v); (* Now we can use [unsafe_set] for the intermediate bytes. *) Caml.String.unsafe_set buf (pos + 1) (Char.unsafe_chr (0xFF land (v asr 48))); Caml.String.unsafe_set buf (pos + 2) (Char.unsafe_chr (0xFF land (v asr 40))); Caml.String.unsafe_set buf (pos + 3) (Char.unsafe_chr (0xFF land (v asr 32))); Caml.String.unsafe_set buf (pos + 4) (Char.unsafe_chr (0xFF land (v asr 24))); Caml.String.unsafe_set buf (pos + 5) (Char.unsafe_chr (0xFF land (v asr 16))); Caml.String.unsafe_set buf (pos + 6) (Char.unsafe_chr (0xFF land (v asr 8))) ;; let pack_signed_64_int_little_endian ~buf ~pos v = (* Safely set the first and last bytes, so that we verify the string bounds. *) buf.[pos] <- Char.unsafe_chr (0xFF land v); buf.[pos + 7] <- Char.unsafe_chr (0xFF land (v asr 56)); (* Now we can use [unsafe_set] for the intermediate bytes. *) Caml.String.unsafe_set buf (pos + 1) (Char.unsafe_chr (0xFF land (v asr 8))); Caml.String.unsafe_set buf (pos + 2) (Char.unsafe_chr (0xFF land (v asr 16))); Caml.String.unsafe_set buf (pos + 3) (Char.unsafe_chr (0xFF land (v asr 24))); Caml.String.unsafe_set buf (pos + 4) (Char.unsafe_chr (0xFF land (v asr 32))); Caml.String.unsafe_set buf (pos + 5) (Char.unsafe_chr (0xFF land (v asr 40))); Caml.String.unsafe_set buf (pos + 6) (Char.unsafe_chr (0xFF land (v asr 48))) ;; let unpack_signed_64_int ~byte_order ~buf ~pos = assert (Sys.word_size = 64); (Char.code buf.[pos + offset ~len:8 ~byte_order 0] lsl 56) lor (Char.code buf.[pos + offset ~len:8 ~byte_order 1] lsl 48) lor (Char.code buf.[pos + offset ~len:8 ~byte_order 2] lsl 40) lor (Char.code buf.[pos + offset ~len:8 ~byte_order 3] lsl 32) lor (Char.code buf.[pos + offset ~len:8 ~byte_order 4] lsl 24) lor (Char.code buf.[pos + offset ~len:8 ~byte_order 5] lsl 16) lor (Char.code buf.[pos + offset ~len:8 ~byte_order 6] lsl 8) lor (Char.code buf.[pos + offset ~len:8 ~byte_order 7]) ;; exception Unpack_signed_64_int_most_significant_byte_too_large of int with sexp let check_highest_order_byte_range byte = if byte < 64 || byte >= 192 then () else raise (Unpack_signed_64_int_most_significant_byte_too_large byte) ;; let unpack_signed_64_int_big_endian ~buf ~pos = assert (Sys.word_size = 64); (* Do bounds checking only on the first and last bytes *) let b1 = Char.code buf.[pos] and b8 = Char.code buf.[pos + 7] in let b2 = Char.code (Caml.String.unsafe_get buf (pos + 1)) and b3 = Char.code (Caml.String.unsafe_get buf (pos + 2)) and b4 = Char.code (Caml.String.unsafe_get buf (pos + 3)) and b5 = Char.code (Caml.String.unsafe_get buf (pos + 4)) and b6 = Char.code (Caml.String.unsafe_get buf (pos + 5)) and b7 = Char.code (Caml.String.unsafe_get buf (pos + 6)) in check_highest_order_byte_range b1; (b1 lsl 56) lor (b2 lsl 48) lor (b3 lsl 40) lor (b4 lsl 32) lor (b5 lsl 24) lor (b6 lsl 16) lor (b7 lsl 8) lor b8 ;; let unpack_signed_64_int_little_endian ~buf ~pos = assert (Sys.word_size = 64); (* Do bounds checking only on the first and last bytes *) let b1 = Char.code buf.[pos] and b8 = Char.code buf.[pos + 7] in let b2 = Char.code (Caml.String.unsafe_get buf (pos + 1)) and b3 = Char.code (Caml.String.unsafe_get buf (pos + 2)) and b4 = Char.code (Caml.String.unsafe_get buf (pos + 3)) and b5 = Char.code (Caml.String.unsafe_get buf (pos + 4)) and b6 = Char.code (Caml.String.unsafe_get buf (pos + 5)) and b7 = Char.code (Caml.String.unsafe_get buf (pos + 6)) in check_highest_order_byte_range b8; b1 lor (b2 lsl 8) lor (b3 lsl 16) lor (b4 lsl 24) lor (b5 lsl 32) lor (b6 lsl 40) lor (b7 lsl 48) lor (b8 lsl 56) ;; IFDEF ARCH_SIXTYFOUR THEN TEST_UNIT "63 bits overflow" = let buf = String.create 8 in let pos = 0 in List.iter [pack_signed_64_little_endian, unpack_signed_64_int_little_endian; pack_signed_64_big_endian, unpack_signed_64_int_big_endian] ~f:(fun (pack, unpack) -> List.iter [ Int64.max_int, Some 127; Int64.min_int, Some 128; Int64.(add (of_int Int.max_value) 1L), Some 64; Int64.(add (of_int Int.min_value) (-1L)), Some 191; Int64.(of_int Int.max_value), None; Int64.(of_int Int.min_value), None; ] ~f:(fun (n, opt) -> pack ~buf ~pos n; try ignore (unpack ~buf ~pos : int); assert (opt = None) with Unpack_signed_64_int_most_significant_byte_too_large n when Some n = opt -> () )) ;; ENDIF TEST_MODULE "inline_signed_64" = Make_inline_tests (struct let ns = [0x3f20_3040_5060_7080L; 0x7f20_3040_5060_7080L; -0x7f20_3040_5060_7080L; 0x7fff_ffff_ffff_ffffL; 0x8000_0000_0000_0000L; 0L] let num_bytes = 8 let signed = true type t = int64 let of_int64 = Fn.id let to_int64 = Fn.id let pack = pack_signed_64 let unpack = unpack_signed_64 let pack_big_endian = pack_signed_64_big_endian let unpack_big_endian = unpack_signed_64_big_endian let pack_little_endian = pack_signed_64_little_endian let unpack_little_endian = unpack_signed_64_little_endian end) IFDEF ARCH_SIXTYFOUR THEN TEST_MODULE "inline_signed_64_int" = Make_inline_tests (struct (* These numbers are written with one endianness and read with the opposite endianness, so the smallest byte becomes the biggest byte. Because of this, the range restriction that applies to the biggest byte also applies to the smallest byte. *) let ns = [0x3f20_3040_5060_0708L; 0x7f20_3040_5060_0708L; -0x7f20_3040_5060_0708L; 0x7fff_ffff_ffff_0000L; 0L] |> List.map ~f:Int64.to_int let num_bytes = 8 let signed = true type t = int let of_int64 = Int64.to_int let to_int64 = Int64.of_int let pack = pack_signed_64_int let unpack = unpack_signed_64_int let pack_big_endian = pack_signed_64_int_big_endian let unpack_big_endian = unpack_signed_64_int_big_endian let pack_little_endian = pack_signed_64_int_little_endian let unpack_little_endian = unpack_signed_64_int_little_endian end) ENDIF let pack_float ~byte_order ~buf ~pos f = pack_signed_64 ~byte_order ~buf ~pos (Int64.bits_of_float f) ;; let unpack_float ~byte_order ~buf ~pos = Int64.float_of_bits (unpack_signed_64 ~byte_order ~buf ~pos) ;; let rec last_nonmatch_plus_one ~buf ~min_pos ~pos ~char = let pos' = pos - 1 in if pos' >= min_pos && Core_char.(=) (String.get buf pos') char then last_nonmatch_plus_one ~buf ~min_pos ~pos:pos' ~char else pos ;; let unpack_tail_padded_fixed_string ?(padding='\x00') ~buf ~pos ~len () = let data_end = last_nonmatch_plus_one ~buf ~min_pos:pos ~pos:(pos + len) ~char:padding in String.sub buf ~pos ~len:(data_end - pos) ;; exception Pack_tail_padded_fixed_string_argument_too_long of [`s of string] * [`longer_than] * [`len of int] with sexp ;; let pack_tail_padded_fixed_string ?(padding='\x00') ~buf ~pos ~len s = let slen = String.length s in if slen > len then raise (Pack_tail_padded_fixed_string_argument_too_long (`s s, `longer_than, `len len)) else begin String.blit ~src:s ~dst:buf ~src_pos:0 ~dst_pos:pos ~len:slen; if slen < len then begin let diff = len - slen in String.fill buf ~pos:(pos + slen) ~len:diff padding end end ;; TEST_MODULE "inline_tail_padded_fixed_string" = struct TEST = last_nonmatch_plus_one ~buf:"222121212" ~min_pos:3 ~pos:9 ~char:'2' = 8 TEST = last_nonmatch_plus_one ~buf:"111121212" ~min_pos:3 ~pos:9 ~char:'1' = 9 TEST = last_nonmatch_plus_one ~buf:"222121222" ~min_pos:3 ~pos:9 ~char:'2' = 6 TEST = last_nonmatch_plus_one ~buf:"222222222" ~min_pos:3 ~pos:9 ~char:'2' = 3 TEST = last_nonmatch_plus_one ~buf:"221222222" ~min_pos:3 ~pos:9 ~char:'2' = 3 TEST = last_nonmatch_plus_one ~buf:"222122222" ~min_pos:3 ~pos:9 ~char:'2' = 4 TEST = last_nonmatch_plus_one ~buf:"222122222" ~min_pos:3 ~pos:9 ~char:'1' = 9 TEST = last_nonmatch_plus_one ~buf:"222122222" ~min_pos:3 ~pos:8 ~char:'1' = 8 TEST = last_nonmatch_plus_one ~buf:"222122221" ~min_pos:3 ~pos:8 ~char:'1' = 8 TEST = last_nonmatch_plus_one ~buf:"222122221" ~min_pos:3 ~pos:8 ~char:'2' = 4 TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..c." ~pos:1 ~len:5 () = "b..c" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..c." ~pos:1 ~len:4 () = "b..c" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..c." ~pos:1 ~len:3 () = "b" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..c." ~pos:1 ~len:2 () = "b" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..c." ~pos:1 ~len:1 () = "b" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..c" ~pos:2 ~len:3 () = "..c" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..c" ~pos:2 ~len:2 () = "" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..cd" ~pos:2 ~len:3 () = "..c" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..cd" ~pos:2 ~len:2 () = "" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:"ab..c." ~pos:2 ~len:1 () = "" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:".....x" ~pos:0 ~len:6 () = ".....x" TEST = unpack_tail_padded_fixed_string ~padding:'.' ~buf:".....x" ~pos:0 ~len:5 () = "" TEST = "1abcd.78" = ( let buf = "12345678" in pack_tail_padded_fixed_string ~padding:'.' ~buf ~pos:1 ~len:5 "abcd"; buf) TEST = "1abcde78" = ( let buf = "12345678" in pack_tail_padded_fixed_string ~padding:'.' ~buf ~pos:1 ~len:5 "abcde"; buf) TEST = "1.....78" = ( let buf = "12345678" in pack_tail_padded_fixed_string ~padding:'.' ~buf ~pos:1 ~len:5 ""; buf) TEST = "1.....78" = ( let buf = "12345678" in pack_tail_padded_fixed_string ~padding:'.' ~buf ~pos:1 ~len:5 "..."; buf) end ;; let test byte_order = let buf = String.make 8 'a' in let test name to_string p u ns = List.iter ns ~f:(fun n -> p ~byte_order ~buf ~pos:0 n; let n' = u ~byte_order ~buf ~pos:0 in if n <> n' then failwith (sprintf "%s = unpack_%s (pack_%s %s)" (to_string n') name name (to_string n))) in test "signed_8" string_of_int (fun ~byte_order:_ ~buf ~pos i -> pack_signed_8 ~buf ~pos i) (fun ~byte_order:_ ~buf ~pos -> unpack_signed_8 ~buf ~pos) [-0x80; -0x7F; -0xF; -1; 0; 1; 0xF; 0x7F]; test "signed_16" string_of_int pack_signed_16 unpack_signed_16 [-0x8000; -0x7ABC; -0xFF; -1; 0; 1; 0xFF; 0x7ABC; 0x7FFF]; test "signed_32" Int32.to_string pack_signed_32 unpack_signed_32 [-0x80000000l; -0x76543210l; -0xFFl; Int32.minus_one; Int32.zero; Int32.one; 0x76543210l; 0x7FFFFFFFl]; test "signed_64" Int64.to_string pack_signed_64 unpack_signed_64 [-0x8000_0000_0000_0000L; -0x789A_BCDE_F012_3456L; -0xFFL; Int64.minus_one; Int64.zero; Int64.one; 0x789A_BCDE_F012_3456L; 0x7FFF_FFFF_FFFF_FFFFL] ;; let test () = test `Big_endian; test `Little_endian core_kernel-113.00.00/src/binary_packing.mli000066400000000000000000000137711256461164500206010ustar00rootroot00000000000000(** Packs and unpacks various types of integers into and from strings. Functions ending in _int should not be used on 32 bit programs because native ocaml ints will not be big enough. [pos] arguments refer to the location in the buf string. We support big and little endian ints. Note that for an 8 bit (1 byte) integer, there is no difference because endian-ness only changes the order of bytes, not bits. *) type endian = [ `Big_endian | `Little_endian ] val unpack_signed_8 : buf:string -> pos:int -> int val pack_signed_8 : buf:string -> pos:int -> int -> unit val unpack_unsigned_8 : buf:string -> pos:int -> int val pack_unsigned_8 : buf:string -> pos:int -> int -> unit (** The functions ending with [_big_endian] or [_little_endian] are faster than the ones with explicit [byte_order] argument: {v Name | Run time | S. dev. | Warnings ---------------------------------- | -------- | ------- | -------- pack_signed_16_little_endian | 4 ns | 0 ns | unpack_signed_16_little_endian | 5 ns | 0 ns | pack_signed_32_int | 12 ns | 0 ns | unpack_signed_32_int | 12 ns | 0 ns | pack_signed_32_int_little_endian | 4 ns | 0 ns | unpack_signed_32_int_little_endian | 5 ns | 0 ns | M pack_signed_64_int | 21 ns | 0 ns | M unpack_signed_64_int | 21 ns | 0 ns | M pack_signed_64_little_endian | 8 ns | 0 ns | unpack_signed_64_little_endian | 9 ns | 0 ns | M v} *) val unpack_signed_16 : byte_order:endian -> buf:string -> pos:int -> int val pack_signed_16 : byte_order:endian -> buf:string -> pos:int -> int -> unit val unpack_unsigned_16_big_endian : buf:string -> pos:int -> int val unpack_unsigned_16_little_endian : buf:string -> pos:int -> int val pack_unsigned_16_big_endian : buf:string -> pos:int -> int -> unit val pack_unsigned_16_little_endian : buf:string -> pos:int -> int -> unit val unpack_signed_16_big_endian : buf:string -> pos:int -> int val unpack_signed_16_little_endian : buf:string -> pos:int -> int val pack_signed_16_big_endian : buf:string -> pos:int -> int -> unit val pack_signed_16_little_endian : buf:string -> pos:int -> int -> unit val unpack_unsigned_16 : byte_order:endian -> buf:string -> pos:int -> int val pack_unsigned_16 : byte_order:endian -> buf:string -> pos:int -> int -> unit val unpack_signed_32 : byte_order:endian -> buf:string -> pos:int -> int32 val unpack_signed_32_int : byte_order:endian -> buf:string -> pos:int -> int val pack_signed_32 : byte_order:endian -> buf:string -> pos:int -> Int32.t -> unit val pack_signed_32_int : byte_order:endian -> buf:string -> pos:int -> int -> unit val unpack_unsigned_32_int_big_endian : buf:string -> pos:int -> int val unpack_unsigned_32_int_little_endian : buf:string -> pos:int -> int val pack_unsigned_32_int_big_endian : buf:string -> pos:int -> int -> unit val pack_unsigned_32_int_little_endian : buf:string -> pos:int -> int -> unit val unpack_signed_32_int_big_endian : buf:string -> pos:int -> int val unpack_signed_32_int_little_endian : buf:string -> pos:int -> int val pack_signed_32_int_big_endian : buf:string -> pos:int -> int -> unit val pack_signed_32_int_little_endian : buf:string -> pos:int -> int -> unit val unpack_unsigned_32_int : byte_order:endian -> buf:string -> pos:int -> int val pack_unsigned_32_int : byte_order:endian -> buf:string -> pos:int -> int -> unit val unpack_signed_64 : byte_order:endian -> buf:string -> pos:int -> int64 val unpack_signed_64_int : byte_order:endian -> buf:string -> pos:int -> int val pack_signed_64 : byte_order:endian -> buf:string -> pos:int -> Int64.t -> unit val pack_signed_64_int : byte_order:endian -> buf:string -> pos:int -> int -> unit val unpack_signed_64_int_little_endian : buf:string -> pos:int -> int val pack_signed_64_int_little_endian : buf:string -> pos:int -> int -> unit val unpack_signed_64_int_big_endian : buf:string -> pos:int -> int val pack_signed_64_int_big_endian : buf:string -> pos:int -> int -> unit val unpack_signed_64_big_endian : buf:string -> pos:int -> int64 val unpack_signed_64_little_endian : buf:string -> pos:int -> int64 val pack_signed_64_big_endian : buf:string -> pos:int -> int64 -> unit val pack_signed_64_little_endian : buf:string -> pos:int -> int64 -> unit (** As with integers, floats can be be packed big endian or little endian, depending on the order in which the bytes of the float are layed out. There is nothing interesting going on computationally from a floating-point perspective; just laying out eight bytes in one order or the other. *) val unpack_float : byte_order:endian -> buf:string -> pos:int -> float val pack_float : byte_order:endian -> buf:string -> pos:int -> float -> unit (** The following functions operate on "fixed length tail padded strings", by which is meant a string possibly followed by some padding, such that the length of the string plus the length of the padding equals the fixed length. *) (** Decode the fixed length tail padded string having length [len] from [buf] starting at [pos]. Return a string containing only the non-padding characters. The default padding is '\x00'. *) val unpack_tail_padded_fixed_string : ?padding:char -> buf:string -> pos:int -> len:int -> unit -> string (** Encode and pack the given string as a tail padded fixed length string having length [len]. Place it in [buf] starting at position [pos]. If the length of the string is less then [len] pad it with the padding characters until its length is equal to [len]. If the string is longer than [len] raise [Invalid_argument]. The default padding is '\x00'. *) val pack_tail_padded_fixed_string : ?padding:char -> buf:string -> pos:int -> len:int -> string -> unit val test : unit -> unit core_kernel-113.00.00/src/binary_searchable.ml000066400000000000000000000336711256461164500211060ustar00rootroot00000000000000let polymorphic_compare = (=) open Int_replace_polymorphic_compare include Binary_searchable_intf module Make_gen (T : sig type 'a elt type 'a t val get : 'a t -> int -> 'a elt val length : _ t -> int module For_test : sig val small : bool elt val big : bool elt val of_array : bool elt array -> bool t end end) = struct (* These functions implement a search for the first (resp. last) element satisfying a predicate, assuming that the predicate is increasing on the container, meaning that, if the container is [u1...un], there exists a k such that p(u1)=....=p(uk) = false and p(uk+1)=....=p(un)= true. If this k = 1 (resp n), find_last_not_satisfaying (resp find_first_satisfying) will return None. *) let rec linear_search_first_satisfying t ~lo ~hi ~pred = if lo > hi then None else if pred (T.get t lo) then Some lo else linear_search_first_satisfying t ~lo:(lo + 1) ~hi ~pred ;; (* Takes a container [t], a predicate [pred] and two indices [lo < hi], such that [pred] is increasing on [t] between [lo] and [hi]. return a range (lo, hi) where: - lo and hi are close enough together for a linear search - If [pred] is not constantly [false] on [t] between [lo] and [hi], the first element on which [pred] is [true] is between [lo] and [hi]. *) (* Invariant: the first element satisfying [pred], if it exists is between [lo] and [hi]*) let rec find_range_near_first_satisfying t ~lo ~hi ~pred = (* Warning: this function will not terminate if the constant (currently 8) is set <= 1 *) if hi - lo <= 8 then (lo,hi) else let mid = lo + ((hi - lo) / 2) in if pred (T.get t mid) (* INVARIANT check: it means the first satisfying element is between [lo] and [mid] *) then find_range_near_first_satisfying t ~lo ~hi:mid ~pred (* INVARIANT check: it means the first satisfying element, if it exists, is between [mid+1] and [hi] *) else find_range_near_first_satisfying t ~lo:(mid+1) ~hi ~pred ;; let find_first_satisfying ?pos ?len t ~pred = let pos, len = Ordered_collection_common.get_pos_len_exn ?pos ?len ~length:(T.length t) in let lo = pos in let hi = pos + len - 1 in let (lo, hi) = find_range_near_first_satisfying t ~lo ~hi ~pred in linear_search_first_satisfying t ~lo ~hi ~pred ;; (* Takes an array with shape [true,...true,false,...false] (i.e., the _reverse_ of what is described above) and returns the index of the last true or None if there are no true*) let find_last_satisfying ?pos ?len t ~pred = let pos, len = Ordered_collection_common.get_pos_len_exn ?pos ?len ~length:(T.length t) in if len = 0 then None else begin (* The last satisfying is the one just before the first not satisfying *) match find_first_satisfying ~pos ~len t ~pred:(fun x -> not (pred x)) with | None -> Some (pos + len - 1) (* This means that all elements satisfy pred. There is at least an element as (len > 0) *) | Some i when i = pos -> None (* no element satisfies pred *) | Some i -> Some (i - 1) end ;; let binary_search ?pos ?len t ~compare how v = match how with | `Last_strictly_less_than -> find_last_satisfying ?pos ?len t ~pred:(fun x -> compare x v < 0) | `Last_less_than_or_equal_to -> find_last_satisfying ?pos ?len t ~pred:(fun x -> compare x v <= 0) | `First_equal_to -> begin match find_first_satisfying ?pos ?len t ~pred:(fun x -> compare x v >= 0) with | Some x when compare (T.get t x) v = 0 -> Some x | None | Some _ -> None end | `Last_equal_to -> begin match find_last_satisfying ?pos ?len t ~pred:(fun x -> compare x v <= 0) with | Some x when compare (T.get t x) v = 0 -> Some x | None | Some _ -> None end | `First_greater_than_or_equal_to -> find_first_satisfying ?pos ?len t ~pred:(fun x -> compare x v >= 0) | `First_strictly_greater_than -> find_first_satisfying ?pos ?len t ~pred:(fun x -> compare x v > 0) ;; let binary_search_segmented ?pos ?len t ~segment_of how = let is_left x = match segment_of x with | `Left -> true | `Right -> false in let is_right x = not (is_left x) in match how with | `Last_on_left -> find_last_satisfying ?pos ?len t ~pred:is_left | `First_on_right -> find_first_satisfying ?pos ?len t ~pred:is_right ;; TEST_MODULE "test_binary_searchable" = struct let compare x y = if x == y then 0 else if x == T.For_test.small then -1 else 1 let elt_compare = compare let s = T.For_test.small let b = T.For_test.big let binary_search ?pos ?len ~compare t how v = binary_search ?pos ?len ~compare (T.For_test.of_array t) how v let (=) = polymorphic_compare TEST = binary_search ~compare [| |] `First_equal_to s = None TEST = binary_search ~compare [| s |] `First_equal_to s = Some 0 TEST = binary_search ~compare [| s |] `First_equal_to b = None TEST = binary_search ~compare [| s ; b |] `First_equal_to s = Some 0 TEST = binary_search ~compare [| s ; b |] `First_equal_to b = Some 1 TEST = binary_search ~compare [| b ; b |] `First_equal_to s = None TEST = binary_search ~compare [| s ; s |] `First_equal_to b = None TEST = binary_search ~compare [| s ; b ; b |] `First_equal_to b = Some 1 TEST = binary_search ~compare [| s ; s ; b |] `First_equal_to s = Some 0 TEST = binary_search ~compare [| b ; b ; b |] `First_equal_to s = None TEST = binary_search ~compare [| |] `Last_equal_to s = None TEST = binary_search ~compare [| s |] `Last_equal_to s = Some 0 TEST = binary_search ~compare [| s |] `Last_equal_to b = None TEST = binary_search ~compare [| s ; b |] `Last_equal_to b = Some 1 TEST = binary_search ~compare [| s ; b |] `Last_equal_to s = Some 0 TEST = binary_search ~compare [| b ; b |] `Last_equal_to s = None TEST = binary_search ~compare [| s ; s |] `Last_equal_to b = None TEST = binary_search ~compare [| s ; b ; b |] `Last_equal_to b = Some 2 TEST = binary_search ~compare [| s ; s ; b |] `Last_equal_to s = Some 1 TEST = binary_search ~compare [| b ; b; b |] `Last_equal_to s = None TEST = binary_search ~compare [||] `First_greater_than_or_equal_to s = None TEST = binary_search ~compare [| b |] `First_greater_than_or_equal_to s = Some 0 TEST = binary_search ~compare [| s |] `First_greater_than_or_equal_to s = Some 0 TEST = binary_search ~compare [| s |] `First_strictly_greater_than s = None TEST = binary_search ~compare [||] `Last_less_than_or_equal_to s = None TEST = binary_search ~compare [| b |] `Last_less_than_or_equal_to s = None TEST = binary_search ~compare [| s |] `Last_less_than_or_equal_to s = Some 0 TEST = binary_search ~compare [| s |] `Last_strictly_less_than s = None let create_test_case (num_s, num_b) = let arr = Array.create (num_s + num_b) b in for i = 0 to num_s -1 do arr.(i) <- s done; arr ;; let only_small = (10_000, 0) let only_big = (0, 10_000) let both = (2531, 4717) TEST = Option.is_some (binary_search (create_test_case only_small) ~compare `First_equal_to s) TEST = let arr = create_test_case both in match binary_search arr ~compare `First_equal_to b with | None -> false | Some v -> v = 2531 TEST = let arr = create_test_case only_small in binary_search arr ~compare `First_equal_to b = None let create_deterministic_test () = Array.init 100_000 (fun i -> if i > 50_000 then b else s) TEST = let arr = create_deterministic_test () in binary_search arr ~compare `First_equal_to s = Some 0 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `Last_equal_to s = Some 50_000 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `First_greater_than_or_equal_to s = Some 0 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `Last_less_than_or_equal_to s = Some 50_000 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `First_strictly_greater_than s = Some 50_001 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `Last_strictly_less_than b = Some 50_000 (* tests around a gap*) TEST = let arr = create_deterministic_test () in binary_search arr ~compare `First_equal_to b = Some 50_001 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `Last_equal_to b = Some 99_999 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `First_greater_than_or_equal_to b = Some 50_001 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `Last_less_than_or_equal_to b = Some 99_999 TEST = let arr = create_deterministic_test () in binary_search arr ~compare `First_strictly_greater_than b = None TEST = let arr = create_deterministic_test () in binary_search arr ~compare `Last_strictly_less_than b = Some 50_000 (* test beginning of array *) TEST = let arr = create_test_case only_big in binary_search arr ~compare `First_equal_to s = None TEST = let arr = create_test_case only_big in binary_search arr ~compare `Last_equal_to s = None TEST = let arr = create_test_case only_big in binary_search arr ~compare `First_greater_than_or_equal_to s = Some 0 TEST = let arr = create_test_case only_big in binary_search arr ~compare `Last_less_than_or_equal_to s = None TEST = let arr = create_test_case only_big in binary_search arr ~compare `First_strictly_greater_than s = Some 0 TEST = let arr = create_test_case only_big in binary_search arr ~compare `Last_strictly_less_than b = None (* test end of array *) TEST = let arr = create_test_case only_small in binary_search arr ~compare `First_equal_to b = None TEST = let arr = create_test_case only_small in binary_search arr ~compare `Last_equal_to b = None TEST = let arr = create_test_case only_small in binary_search arr ~compare `First_greater_than_or_equal_to b = None TEST = let arr = create_test_case only_small in binary_search arr ~compare `Last_less_than_or_equal_to b = Some 9_999 TEST = let arr = create_test_case only_small in binary_search arr ~compare `First_strictly_greater_than s = None TEST = let arr = create_test_case only_small in binary_search arr ~compare `Last_strictly_less_than b = Some 9_999 TEST_UNIT = let open Result in for length = 0 to 5 do for num_s = 0 to length do let arr = Array.init length (fun i -> if i < num_s then s else b) in for pos = -1 to length do for len = -1 to length + 1 do (*try*) let should_raise = Exn.does_raise (fun () -> Ordered_collection_common.check_pos_len_exn ~pos ~len ~length) in let result = Or_error.try_with (fun () -> binary_search arr ~pos ~len ~compare:elt_compare `Last_equal_to s) in match should_raise, result with | true , Error _ -> () | true , Ok _ -> failwith "expected it to raise but it didn't" | false, Error _ -> failwith "expected it to not raise, but it raised" | false, Ok result -> let searched = num_s - 1 in let correct_result = if searched < pos then None else if len = 0 then None else if searched >= pos + len then Some(pos + len - 1) else Some searched in if not (correct_result = result) then failwith "Wrong result" (*with exn -> failwiths "binary_search bug" (exn, `length length, `search_key search_key, `pos pos, `len len) <:sexp_of< exn * [ `length of int ] * [ `search_key of int ] * [ `pos of int ] * [ `len of int ] >>*) done; done; done; done; ;; let binary_search_segmented a = binary_search_segmented (T.For_test.of_array a) (*test for binary_search_segmented*) TEST = let arr = create_deterministic_test () in let segment_of x = if x = b then `Right else `Left in binary_search_segmented arr ~segment_of `Last_on_left = Some 50_000 && binary_search_segmented arr ~segment_of `First_on_right = Some 50_001 TEST = let arr = create_deterministic_test () in let segment_of _ = `Right in binary_search_segmented arr ~segment_of `Last_on_left = None && binary_search_segmented arr ~segment_of `First_on_right = Some 0 TEST = let arr = create_deterministic_test () in let segment_of _ = `Left in binary_search_segmented arr ~segment_of `Last_on_left = Some 99_999 && binary_search_segmented arr ~segment_of `First_on_right = None end end module Make (T : Indexable) = Make_gen (struct type 'a elt = T.elt type 'a t = T.t include (T : Indexable with type elt := T.elt with type t := T.t) end) module Make1 (T : Indexable1) = Make_gen (struct type 'a elt = 'a type 'a t = 'a T.t let get = T.get let length = T.length module For_test = struct include T.For_test let small = false let big = true end end) core_kernel-113.00.00/src/binary_searchable.mli000066400000000000000000000001271256461164500212450ustar00rootroot00000000000000(** See {!Binary_searchable_intf}. *) include Binary_searchable_intf.Binary_searchable core_kernel-113.00.00/src/binary_searchable_intf.ml000066400000000000000000000117641256461164500221250ustar00rootroot00000000000000(** Module types for a [binary_search] function for a sequence, and functors for building [binary_search] functions. *) (** An [Indexable] type is a finite sequence of elements indexed by consecutive integers [0] ... [length t - 1]. [get] and [length] must be O(1) for the resulting [binary_search] to be lg(n). *) module type Indexable = sig type elt type t val get : t -> int -> elt val length : t -> int (** To implement the test provided by [Binary_searchable], we need to be able to construct [t] with two different values [small < big]. We also need to be able to build a [t] from an [elt array]. *) module For_test : sig val small : elt val big : elt val of_array : elt array -> t end end module type Indexable1 = sig type 'a t val get : 'a t -> int -> 'a val length : _ t -> int module For_test : sig val of_array : bool array -> bool t end end type ('t, 'elt) binary_search = ?pos:int -> ?len:int -> 't -> compare:('elt -> 'elt -> int) -> [ `Last_strictly_less_than (** {v | < elt X | v} *) | `Last_less_than_or_equal_to (** {v | <= elt X | v} *) | `Last_equal_to (** {v | = elt X | v} *) | `First_equal_to (** {v | X = elt | v} *) | `First_greater_than_or_equal_to (** {v | X >= elt | v} *) | `First_strictly_greater_than (** {v | X > elt | v} *) ] -> 'elt -> int option type ('t, 'elt) binary_search_segmented = ?pos:int -> ?len:int -> 't -> segment_of:('elt -> [ `Left | `Right ]) -> [ `Last_on_left | `First_on_right ] -> int option module type S = sig type elt type t (** {0:Examples} The functions produced by this functor are very powerful, but also somewhat complex to read. Here are some simple examples to clarify the use cases. Below we assume that the function [compare] is in scope: {[ (* find the index of an element [e] in [t] *) binary_search t ~compare `First_equal_to e; (* find the index where an element [e] should be inserted *) binary_search t ~compare `First_greater_than_or_equal_to e; (* find the index in [t] where all elements to the left are less than [e] *) binary_search_segmented t ~segment_of:(fun e' -> if compare e' e <= 0 then `Left else `Right) `First_on_right ]} *) (** [binary_search ?pos ?len t ~compare which elt] takes [t] that is sorted in nondecreasing order according to [compare], where [compare] and [elt] divide [t] into three (possibly empty) segments: {v | < elt | = elt | > elt | v} [binary_search] returns the index in [t] of an element on the boundary of segments as specified by [which]. See the diagram below next to the [which] variants. By default, [binary_search] searches the entire [t]. One can supply [?pos] or [?len] to search a slice of [t]. [binary_search] does not check that [compare] orders [t], and behavior is unspecified if [compare] doesn't order [t]. Behavior is also unspecified if [compare] mutates [t]. *) val binary_search : (t, elt) binary_search (** [binary_search_segmented ?pos ?len t ~segment_of which] takes an [segment_of] function that divides [t] into two (possibly empty) segments: {v | segment_of elt = `Left | segment_of elt = `Right | v} [binary_search_segmented] returns the index of the element on the boundary of the segments as specified by [which]: [`Last_on_left] yields the index of the last element of the left segment, while [`First_on_right] yields the index of the first element of the right segment. It returns [None] if the segment is empty. By default, [binary_search] searches the entire [t]. One can supply [?pos] or [?len] to search a slice of [t]. [binary_search_segmented] does not check that [segment_of] segments [t] as in the diagram, and behavior is unspecified if [segment_of] doesn't segment [t]. Behavior is also unspecified if [segment_of] mutates [t]. *) val binary_search_segmented : (t, elt) binary_search_segmented end module type S1 = sig type 'a t val binary_search : ('a t, 'a) binary_search val binary_search_segmented : ('a t, 'a) binary_search_segmented end module type S1_permissions = sig open Perms.Export type ('a, -'perms) t val binary_search : (('a, [> read]) t, 'a) binary_search val binary_search_segmented : (('a, [> read]) t, 'a) binary_search_segmented end module type Binary_searchable = sig module type S = S module type S1 = S1 module type S1_permissions = S1_permissions module type Indexable = Indexable module type Indexable1 = Indexable1 module Make (T : Indexable) : S with type t := T.t with type elt := T.elt module Make1 (T : Indexable1) : S1 with type 'a t := 'a T.t end core_kernel-113.00.00/src/blang.ml000066400000000000000000000377501256461164500165360ustar00rootroot00000000000000open Std_internal (* the module [T] serves to enforce the invariant that all Blang.t values are in a normal form whereby boolean constants True and False only appear as the topmost constructor -- in any other position they are simplified away using laws of boolean algebra. Note: this file deviates from the usual pattern of modules with Stable interfaces in that the Stable sub-module is not the first thing to be defined in the module. The reason for this deviation is so that one can convince oneself of the aforementioned invariant after reading only this small amount of code. After defining T we then immediately define its Stable interface. *) module T : sig type 'a t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a with bin_io, compare val invariant : 'a t -> unit val true_ : 'a t val false_ : 'a t val not_ : 'a t -> 'a t val andalso : 'a t -> 'a t -> 'a t val orelse : 'a t -> 'a t -> 'a t val if_ : 'a t -> 'a t -> 'a t -> 'a t val base : 'a -> 'a t end = struct type 'a t = | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a with bin_io, compare let invariant = let subterms = function | True | False | Base _ -> [] | Not t1 -> [t1] | And (t1, t2) | Or (t1, t2) -> [t1; t2] | If (t1, t2, t3) -> [t1; t2; t3] in let rec contains_no_constants = function | True | False -> assert false | t -> List.iter ~f:contains_no_constants (subterms t) in fun t -> List.iter ~f:contains_no_constants (subterms t) let true_ = True let false_ = False let base v = Base v let not_ = function | True -> False | False -> True | Not t -> t | t -> Not t let andalso t1 t2 = match (t1, t2) with | (_, False) | (False, _) -> False | (other, True) | (True, other) -> other | _ -> And (t1, t2) let orelse t1 t2 = match (t1, t2) with | (_, True) | (True, _) -> True | (other, False) | (False, other) -> other | _ -> Or (t1, t2) let if_ a b c = match a with | True -> b | False -> c | _ -> match (b, c) with | (True, _ ) -> orelse a c | (_, False) -> andalso a b | (_, True ) -> orelse (not_ a) b | (False, _) -> andalso (not_ a) c | _ -> If (a, b, c) end include T module Stable = struct module V1 : sig (* THIS TYPE AND ITS SERIALIZATIONS SHOULD NEVER BE CHANGED - PLEASE SPEAK WITH ANOTHER DEVELOPER IF YOU NEED MORE DETAIL *) type 'a t = 'a T.t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a with bin_io, compare, sexp (* the remainder of this signature consists of functions used in the definitions of sexp conversions that are also useful more generally *) val and_ : 'a t list -> 'a t val or_ : 'a t list -> 'a t val gather_conjuncts : 'a t -> 'a t list val gather_disjuncts : 'a t -> 'a t list end = struct type 'a t = 'a T.t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a include (T : sig type 'a t with bin_io, compare end with type 'a t := 'a t) type sexp = Sexp.t = Atom of string | List of sexp list (* cheap import *) (* flatten out nested and's *) let gather_conjuncts t = let rec loop acc = function | True :: ts -> loop acc ts | And (t1, t2) :: ts -> loop acc (t1 :: t2 :: ts) | t :: ts -> loop (t :: acc) ts | [] -> List.rev acc in loop [] [t] (* flatten out nested or's *) let gather_disjuncts t = let rec loop acc = function | False :: ts -> loop acc ts | Or (t1, t2) :: ts -> loop acc (t1 :: t2 :: ts) | t :: ts -> loop (t :: acc) ts | [] -> List.rev acc in loop [] [t] let and_ ts = let rec loop acc = function | [] -> acc | False :: _ -> false_ (* short circuit evaluation *) | t :: ts -> loop (andalso acc t) ts in loop true_ ts let or_ ts = let rec loop acc = function | [] -> acc | True :: _ -> true_ (* short circuit evaluation *) | t :: ts -> loop (orelse acc t) ts in loop false_ ts let unary name args sexp = match args with | [x] -> x | _ -> let n = List.length args in of_sexp_error (sprintf "%s expects one argument, %d found" name n) sexp let ternary name args sexp = match args with | [x; y; z] -> (x, y, z) | _ -> let n = List.length args in of_sexp_error (sprintf "%s expects three arguments, %d found" name n) sexp let sexp_of_t sexp_of_value t = let rec aux t = match t with | Base x -> sexp_of_value x | True -> Atom "true" | False -> Atom "false" | Not t -> List [Atom "not"; aux t] | If (t1, t2, t3) -> List [Atom "if"; aux t1; aux t2; aux t3] | And _ as t -> let ts = gather_conjuncts t in List (Atom "and" :: List.map ~f:aux ts) | Or _ as t -> let ts = gather_disjuncts t in List (Atom "or" :: List.map ~f:aux ts) in aux t let t_of_sexp base_of_sexp sexp = let base sexp = base (base_of_sexp sexp) in let rec aux sexp = match sexp with | Atom kw -> begin match String.lowercase kw with | "true" -> true_ | "false" -> false_ | _ -> base sexp end | List (Atom kw :: args) -> begin match String.lowercase kw with | "and" -> and_ (List.map ~f:aux args) | "or" -> or_ (List.map ~f:aux args) | "not" -> not_ (aux (unary "not" args sexp)) | "if" -> let (x, y, z) = ternary "if" args sexp in if_ (aux x) (aux y) (aux z) | _ -> base sexp end | _ -> base sexp in aux sexp end TEST_MODULE "Blang.V1" = Stable_unit_test.Make (struct type t = string V1.t with sexp, bin_io open V1 let equal = Pervasives.(=) let test_blang = (if_ (base "foo") (not_ (or_ [(base "bara"); (base "barb")])) (not_ (and_ [(base "baza"); (base "bazb")]))) let test_sexp = "(if foo (not (or bara barb)) (not (and baza bazb)))" let test_bin = "\005\006\003foo\ \004\003\006\004bara\006\004barb\ \004\002\006\004baza\006\004bazb" let tests = [ test_blang, test_sexp, test_bin ; true_, "true", "\000" ; false_, "false", "\001" ] end) end include (Stable.V1 : module type of Stable.V1 with type 'a t := 'a t) TEST_MODULE "auto-simplification" = struct let (a, b, c) = (base 1, base 2, base 3) let (=) a b = invariant a; invariant b; Pervasives.(=) a b TEST = not_ true_ = false_ TEST = not_ false_ = true_ TEST = not_ (not_ a) = a TEST = andalso true_ b = b TEST = andalso a true_ = a TEST = andalso false_ b = false_ TEST = andalso a false_ = false_ TEST = orelse false_ b = b TEST = orelse a false_ = a TEST = orelse true_ b = true_ TEST = orelse a true_ = true_ TEST = if_ true_ b c = b TEST = if_ false_ b c = c TEST = if_ a true_ c = orelse a c TEST = if_ a b false_ = andalso a b TEST = if_ a b true_ = if_ (not_ a) true_ b (* b/c (if a b c) = (if (not a) c b) *) TEST = if_ a b true_ = orelse (not_ a) b TEST = if_ a false_ c = if_ (not_ a) c false_ (* b/c (if a b c) = (if (not a) c b) *) TEST = if_ a false_ c = andalso (not_ a) c TEST_MODULE "n-ary-and-or" = struct TEST = and_ [a; b; c] = andalso (andalso a b) c TEST = or_ [a; b; c] = orelse (orelse a b) c let test_and ts = (and_ ts = List.fold ts ~init:true_ ~f:andalso) let test_or ts = (or_ ts = List.fold ts ~init:false_ ~f:orelse) TEST = test_or [] TEST = test_or [a] TEST = test_or [true_] TEST = test_or [false_] TEST = test_or [a; true_; b] TEST = test_or [a; false_; b] TEST = test_and [] TEST = test_and [a] TEST = test_and [true_] TEST = test_and [false_] TEST = test_and [a; true_; b] TEST = test_and [a; false_; b] end end let constant b = if b then true_ else false_ let constant_value = function | True -> Some true | False -> Some false | _ -> None (* [values t] lists the base predicates in [t] from left to right *) let values t = let rec loop acc = function | Base v :: ts -> loop (v :: acc) ts | True :: ts -> loop acc ts | False :: ts -> loop acc ts | Not t1 :: ts -> loop acc (t1 :: ts) | And (t1, t2) :: ts -> loop acc (t1 :: t2 :: ts) | Or (t1, t2) :: ts -> loop acc (t1 :: t2 :: ts) | If (t1, t2, t3) :: ts -> loop acc (t1 :: t2 :: t3 :: ts) | [] -> List.rev acc in loop [] [t] TEST = [1; 2; 3; 4; 5; 6; 7] = values (and_ [ or_ [base 1; base 2]; base 3; true_; if_ (base 4) (base 5) (base 6); not_ (base 7); ]) TEST = gather_conjuncts (base 1) = [base 1] TEST = gather_conjuncts (and_ []) = [] TEST = gather_conjuncts (and_ [base 1]) = [base 1] TEST = gather_conjuncts (and_ [base 1; base 2]) = [base 1; base 2] TEST = gather_conjuncts (and_ [base 1; base 2; base 3]) = [base 1; base 2; base 3] TEST = gather_conjuncts (and_ [ and_ [and_ [base 1; base 2]; base 3]; and_ [or_ [base 4; base 5]; and_ [base 6; base 7]]; ]) = [base 1; base 2; base 3; or_ [base 4; base 5]; base 6; base 7] TEST = gather_disjuncts (base 1) = [base 1] TEST = gather_disjuncts (or_ []) = [] TEST = gather_disjuncts (or_ [base 1]) = [base 1] TEST = gather_disjuncts (or_ [base 1; base 2]) = [base 1; base 2] TEST = gather_disjuncts (or_ [base 1; base 2; base 3]) = [base 1; base 2; base 3] TEST = gather_disjuncts (or_ [ or_ [or_ [base 1; base 2]; base 3]; or_ [and_ [base 4; base 5]; or_ [base 6; base 7]]; ]) = [base 1; base 2; base 3; and_ [base 4; base 5]; base 6; base 7] module C = Container.Make (struct type 'a t = 'a T.t let fold t ~init ~f = let rec loop acc t pending = match t with | Base a -> next (f acc a) pending | True | False -> next acc pending | Not t -> loop acc t pending | And (t1, t2) | Or (t1, t2) -> loop acc t1 (t2 :: pending) | If (t1, t2, t3) -> loop acc t1 (t2 :: t3 :: pending) and next acc = function | [] -> acc | t :: ts -> loop acc t ts in loop init t [] let iter = `Define_using_fold end) let count = C.count let sum = C.sum let exists = C.exists let find = C.find let find_map = C.find_map let fold = C.fold let for_all = C.for_all let is_empty = C.is_empty let iter = C.iter let length = C.length let mem = C.mem let to_array = C.to_array let to_list = C.to_list let min_elt = C.min_elt let max_elt = C.max_elt include Monad.Make (struct type 'a t = 'a T.t let return = base let rec bind t k = match t with | Base v -> k v | True -> true_ | False -> false_ | Not t1 -> not_ (bind t1 k) (* Unfortunately we need to duplicate some of the short-circuiting from [andalso] and friends here. In principle we could do something involving [Lazy.t] but the overhead probably wouldn't be worth it. *) | And (t1, t2) -> begin match bind t1 k with | False -> false_ | other -> andalso other (bind t2 k) end | Or (t1, t2) -> begin match bind t1 k with | True -> true_ | other -> orelse other (bind t2 k) end | If (t1, t2, t3) -> begin match bind t1 k with | True -> bind t2 k | False -> bind t3 k | other -> if_ other (bind t2 k) (bind t3 k) end ;; let map = `Define_using_bind end) TEST_MODULE "bind short-circuiting" = struct let test expected_visits expr = let visited = ref [] in let f var = visited := var :: !visited; false_ in match bind expr f with | True -> List.equal ~equal:Int.equal expected_visits (List.rev !visited) | _ -> false TEST = test [0] (or_ [not_ (base 0); base 1]) TEST = test [0; 1] (not_ (and_ [not_ (base 0); base 1; base 2])) TEST = test [0; 2] (if_ (base 0) (base 1) (not_ (base 2))) end (* semantics *) let eval t base_eval = let rec eval = function | True -> true | False -> false | And (t1, t2) -> eval t1 && eval t2 | Or (t1, t2) -> eval t1 || eval t2 | Not t -> not (eval t) | If (t1, t2, t3) -> if eval t1 then eval t2 else eval t3 | Base x -> base_eval x in eval t let specialize t f = bind t (fun v -> match f v with | `Known c -> constant c | `Unknown -> base v) TEST_MODULE "laws" = struct type base = A | B | C with sexp_of type 'a base_fun = base -> 'a let sexp_of_base_fun sexp_of_a (f : 'a base_fun) = Sexp.List [ Sexp.Atom "function"; Sexp.List [Sexp.Atom "A"; Sexp.Atom "->"; sexp_of_a (f A)]; Sexp.List [Sexp.Atom "B"; Sexp.Atom "->"; sexp_of_a (f B)]; Sexp.List [Sexp.Atom "C"; Sexp.Atom "->"; sexp_of_a (f C)]; ] module Gen = struct (* all random values are generated from a fixed PRNG seed so that unit tests are deterministic *) let prng = Random.State.make (String.to_list "31bb128c352e2569228fbacc590e937a29a8bb8f\ c4bfe7126504ce3dc400be7f401fa6f5be5dba38" |! Array.of_list |! Array.map ~f:Char.to_int) let bool () = Random.State.bool prng let element arr = arr.(Random.State.int prng (Array.length arr)) let gen_blang gen_base = let atomic = [| (fun () -> constant (bool ())); (fun () -> base (gen_base ())); |] in let composite = [| (fun rand -> not_ (rand ())); (fun rand -> andalso (rand ()) (rand ())); (fun rand -> orelse (rand ()) (rand ())); (fun rand -> if_ (rand ()) (rand ()) (rand ())); |] in let rec aux ~depth = if depth <= 1 then element atomic () else element composite (fun () -> aux ~depth:(depth - 1)) in aux let gen_base = let bases = [| A; B; C |] in fun () -> element bases let gen_base_fun codomain = fun () -> let a_val = element codomain in let b_val = element codomain in let c_val = element codomain in function | A -> a_val | B -> b_val | C -> c_val let t () = gen_blang gen_base ~depth:5 let f = gen_base_fun [| true; false |] let g = gen_base_fun [| `Unknown; `Known true; `Known false |] let tf () = (t (), f ()) let tg () = (t (), g ()) end let law gen sexp_of run = for _i = 0 to 100 do let arg = gen () in if not (run arg) then failwith (Sexp.to_string (sexp_of arg)) done let forall_t = law Gen.t <:sexp_of> let forall_tf = law Gen.tf <:sexp_of> let forall_tg = law Gen.tg <:sexp_of> TEST_UNIT = forall_t (fun t -> specialize t (fun _ -> `Unknown) = t) TEST_UNIT = forall_tf (fun (t, f) -> specialize t (fun x -> `Known (f x)) = constant (eval t f)) TEST_UNIT = forall_tg (fun (t, g) -> List.for_all (values (specialize t g)) ~f:(fun x -> g x = `Unknown)) TEST_UNIT = forall_tg (fun (t, g) -> (* an arbitrary [f] such that [f x = b] whenever [g x = `Known b] *) let f = let rand_fval x = match g x with `Known b -> b | `Unknown -> Gen.bool () in let a_val = rand_fval A in let b_val = rand_fval B in let c_val = rand_fval C in function | A -> a_val | B -> b_val | C -> c_val in eval t f = eval (specialize t g) f) end core_kernel-113.00.00/src/blang.mli000066400000000000000000000117401256461164500166760ustar00rootroot00000000000000(** A simple boolean domain-specific language *) (** Blang provides infrastructure for writing simple boolean DSLs. All expressions in a Blang language evaluate to a bool. The language is parameterized over another language of base propositions. The syntax is almost exactly the obvious s-expression syntax, except that: 1. Base elements are not marked explicitly. Thus, if your base language has elements FOO, BAR, etc., then you could write the following Blang s-expressions: {v FOO (and FOO BAR) (if FOO BAR BAZ) v} and so on. Note that this gets in the way of using the blang "keywords" in your value language. 2. And and Or take a variable number of arguments, so that one can (and probably should) write {v (and FOO BAR BAZ QUX) v} instead of {v (and FOO (and BAR (and BAZ QUX))) v} *) open Std_internal type 'a t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a with bin_io, compare, sexp (** Note that the sexps are not directly inferred from the type above -- there are lots of fancy shortcuts. Also, the sexps for ['a] must not look anything like blang sexps. Otherwise [t_of_sexp] will fail. *) (** {6 smart constructors that simplify away constants whenever possible} *) val base : 'a -> 'a t val true_ : _ t val false_ : _ t val constant : bool -> _ t (** [function true -> true_ | false -> false_] *) val not_ : 'a t -> 'a t val and_ : 'a t list -> 'a t (** n-ary [And] *) val or_ : 'a t list -> 'a t (** n-ary [Or] *) val if_ : 'a t -> 'a t -> 'a t -> 'a t (** [if_ if then else] *) (** [constant_value t = Some b] iff [t = constant b] *) val constant_value : 'a t -> bool option (** The following two functions are useful when one wants to pretend that ['a t] has constructors And and Or of type ['a t list -> 'a t]. The pattern of use is {[ match t with | ... | And (_, _) as t -> let ts = gather_conjuncts t in ... | Or (_, _) as t -> let ts = gather_disjuncts t in ... | ... ]} or, in case you also want to handle True (resp. False) as a special case of conjunction (disjunction) {[ match t with | ... | True | And (_, _) as t -> let ts = gather_conjuncts t in ... | False | Or (_, _) as t -> let ts = gather_disjuncts t in ... | ... ]} *) (** [gather_conjuncts t] gathers up all toplevel conjuncts in [t]. For example, {ul {- [gather_conjuncts (and_ ts) = ts] } {- [gather_conjuncts (And (t1, t2)) = gather_conjuncts t1 @ gather_conjuncts t2] } {- [gather_conjuncts True = [] ] } {- [gather_conjuncts t = [t]] when [t] matches neither [And (_, _)] nor [True] } } *) val gather_conjuncts : 'a t -> 'a t list (** [gather_disjuncts t] gathers up all toplevel disjuncts in [t]. For example, {ul {- [gather_disjuncts (or_ ts) = ts] } {- [gather_disjuncts (Or (t1, t2)) = gather_disjuncts t1 @ gather_disjuncts t2] } {- [gather_disjuncts False = [] ] } {- [gather_disjuncts t = [t]] when [t] matches neither [Or (_, _)] nor [False] } } *) val gather_disjuncts : 'a t -> 'a t list include Container.S1 with type 'a t := 'a t (** [Blang.t] sports a substitution monad: {ul {- [return v] is [Base v] (think of [v] as a variable) } {- [bind t f] replaces every [Base v] in [t] with [f v] (think of [v] as a variable and [f] as specifying the term to substitute for each variable) } } Note: [bind t f] does short-circuiting, so [f] may not be called on every variable in [t]. *) include Monad with type 'a t := 'a t (** [values t] forms the list containing every [v] for which [Base v] is a subexpression of [t] *) val values : 'a t -> 'a list (** [eval t f] evaluates the proposition [t] relative to an environment [f] that assigns truth values to base propositions. *) val eval : 'a t -> ('a -> bool) -> bool (** [specialize t f] partially evaluates [t] according to a perhaps-incomplete assignment [f] of the values of base propositions. The following laws (at least partially) characterize its behavior. - [specialize t (fun _ -> `Unknown) = t] - [specialize t (fun x -> `Known (f x)) = constant (eval t f)] - [List.for_all (values (specialize t g)) ~f:(fun x -> g x = `Unknown)] - {[ if List.for_all (values t) ~f:(fun x -> match g x with | `Known b -> b = f x | `Unknown -> true) then eval t f = eval (specialize t g) f ]} *) val specialize : 'a t -> ('a -> [`Known of bool | `Unknown]) -> 'a t val invariant : 'a t -> unit module Stable : sig module V1 : sig type nonrec 'a t = 'a t = private | True | False | And of 'a t * 'a t | Or of 'a t * 'a t | Not of 'a t | If of 'a t * 'a t * 'a t | Base of 'a with sexp, bin_io, compare end end core_kernel-113.00.00/src/blit.ml000066400000000000000000000233601256461164500163750ustar00rootroot00000000000000open Sexplib.Conv module Sexp = Sexplib.Sexp open Result.Export module List = Core_list module Array = StdLabels.Array let _log s a sexp_of_a = Printf.eprintf "%s\n%!" (Sexp.to_string_hum (<:sexp_of< string * a >> (s, a))); ;; let ok_exn = Or_error.ok_exn let failwiths = Error.failwiths include Blit_intf module type Sequence_gen = sig type 'a elt type 'a t with sexp_of val length : _ t -> int type 'a z val create_bool : len:int -> bool z t val get : 'a z t -> int -> 'a elt val set : 'a z t -> int -> 'a elt -> unit end module Make_gen (Elt : sig type 'a t val equal : bool t -> bool t -> bool val of_bool : bool -> bool t end) (Src : Sequence_gen with type 'a elt := 'a Elt.t) (Dst : sig include Sequence_gen with type 'a elt := 'a Elt.t with type 'a z := 'a Src.z val create_like : len:int -> 'a Src.t -> 'a t val unsafe_blit : ('a Src.t, 'a t) blit val overlapping_src_dst : [ `Do_not_check | `Check of ('a Src.t -> 'a t) ] end) = struct let unsafe_blit = Dst.unsafe_blit let blit ~src ~src_pos ~dst ~dst_pos ~len = Ordered_collection_common.check_pos_len_exn ~pos:src_pos ~len ~length:(Src.length src); Ordered_collection_common.check_pos_len_exn ~pos:dst_pos ~len ~length:(Dst.length dst); if len > 0 then unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len; ;; let blito ~src ?(src_pos = 0) ?(src_len = Src.length src - src_pos) ~dst ?(dst_pos = 0) () = blit ~src ~src_pos ~len:src_len ~dst ~dst_pos; ;; (* [sub] and [subo] ensure that every position of the created sequence is populated by an element of the source array. Thus every element of [dst] below is well defined. *) let sub src ~pos ~len = Ordered_collection_common.check_pos_len_exn ~pos ~len ~length:(Src.length src); let dst = Dst.create_like ~len src in if len > 0 then unsafe_blit ~src ~src_pos:pos ~dst ~dst_pos:0 ~len; dst ;; let subo ?(pos = 0) ?len src = sub src ~pos ~len:(match len with Some i -> i | None -> Src.length src - pos) ;; let init ~len ~create ~set ~f = let t = create ~len in for i = 0 to len - 1 do set t i (f i); done; t ;; (* Test [blit]. *) TEST_UNIT = let elt1 = Elt.of_bool true in let elt2 = Elt.of_bool false in assert (not (Elt.equal elt1 elt2)); let src_bit i = if i land 0x1 = 0 then elt1 else elt2 in let dst_bit i = if i land 0x1 = 0 then elt2 else elt1 in let n = 4 in for src_length = 0 to n do for dst_length = 0 to n do for src_pos = 0 to src_length do for dst_pos = 0 to dst_length do for src_len = 0 to min (src_length - src_pos) (dst_length - dst_pos) do try let is_in_range i = i >= dst_pos && i < dst_pos + src_len in let check length get = fun name sequence ~expect -> for i = 0 to length sequence - 1 do if not (Elt.equal (get sequence i) (expect i)) then failwiths "bug" (name, `i i) <:sexp_of< string * [ `i of int ] >> done; in let check_src = check Src.length Src.get in let check_dst = check Dst.length Dst.get in let src = init ~len:src_length ~create:Src.create_bool ~set:Src.set ~f:src_bit in assert (Src.length src = src_length); let dst = init ~len:dst_length ~create:Dst.create_bool ~set:Dst.set ~f:dst_bit in assert (Dst.length dst = dst_length); let init_src () = for i = 0 to src_length - 1 do Src.set src i (src_bit i); done in blito ~src ~src_pos ~src_len ~dst ~dst_pos (); check_src "blit src" src ~expect:src_bit; check_dst "blit dst" dst ~expect:(fun i -> if is_in_range i then src_bit (src_pos + i - dst_pos) else dst_bit i); begin match Dst.overlapping_src_dst with | `Do_not_check -> () | `Check src_to_dst -> if dst_pos + src_len <= src_length then begin init_src (); let dst = src_to_dst src in if false then begin blito ~src ~src_pos ~src_len ~dst ~dst_pos (); check_dst "blit dst overlapping" dst ~expect:(fun i -> src_bit (if is_in_range i then (src_pos + i - dst_pos) else i)); end; end; end; (* Check [sub]. *) init_src (); let dst = sub src ~pos:src_pos ~len:src_len in check_src "sub src" src ~expect:src_bit; check_dst "sub dst" dst ~expect:(fun i -> src_bit (src_pos + i)); with exn -> failwiths "bug" (exn, `src_length src_length, `src_pos src_pos, `dst_length dst_length, `dst_pos dst_pos) <:sexp_of< exn * [ `src_length of int ] * [ `src_pos of int ] * [ `dst_length of int ] * [ `dst_pos of int ] >> done; done; done; done; done; ;; end type 'a poly = 'a module Make1 (Sequence : sig include Sequence_gen with type 'a elt := 'a poly val create_like : len:int -> 'a t -> 'a t val unsafe_blit : ('a t, 'a t) blit end) = Make_gen (struct type 'a t = 'a let equal = (=) let of_bool = Fn.id end) (Sequence) (struct include Sequence let overlapping_src_dst = `Check Fn.id end) module Elt_to_elt1 (Elt : Elt) = struct type 'a t = Elt.t let equal = Elt.equal let of_bool = Elt.of_bool end module Make (Elt : Elt) (Sequence : sig include Sequence with type elt := Elt.t val unsafe_blit : (t, t) blit end) = struct module Sequence = struct type 'a t = Sequence.t with sexp_of type 'a z = unit open Sequence let create_like ~len _ = create ~len let length = length let get = get let set = set let unsafe_blit = unsafe_blit let create_bool = create let overlapping_src_dst = `Check Fn.id end include Make_gen (Elt_to_elt1 (Elt)) (Sequence) (Sequence) end module Make_distinct (Elt : Elt) (Src : Sequence with type elt := Elt.t) (Dst : sig include Sequence with type elt := Elt.t val unsafe_blit : (Src.t, t) blit end) = Make_gen (Elt_to_elt1 (Elt)) (struct type 'a t = Src.t with sexp_of type 'a z = unit open Src let length = length let get = get let set = set let create_bool = create end) (struct type 'a t = Dst.t with sexp_of open Dst let length = length let get = get let set = set let create_bool = create let create_like ~len _ = create ~len let unsafe_blit = unsafe_blit let overlapping_src_dst = `Do_not_check end) (* This unit test checks that when [blit] calls [unsafe_blit], the slices are valid. It also checks that [blit] doesn't call [unsafe_blit] when there is a range error. *) TEST_MODULE = struct let blit_was_called = ref false let slices_are_valid = ref (Ok ()) module B = Make (struct type t = bool let equal (t1 : t) t2 = t1 = t2 let of_bool = Fn.id end) (struct type t = bool array with sexp_of let create ~len = Array.create len false let length = Array.length let get = Array.get let set = Array.set let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len = blit_was_called := true; slices_are_valid := Or_error.try_with (fun () -> assert (len >= 0); assert (src_pos >= 0); assert (src_pos + len <= Array.length src); assert (dst_pos >= 0); assert (dst_pos + len <= Array.length dst)); Array.blit ~src ~src_pos ~dst ~dst_pos ~len; ;; end) ;; TEST_UNIT = let opts = [ None; Some (-1); Some 0; Some 1; Some 2 ] in List.iter [ 0; 1; 2 ] ~f:(fun src -> List.iter [ 0; 1; 2 ] ~f:(fun dst -> List.iter opts ~f:(fun src_pos -> List.iter opts ~f:(fun src_len -> List.iter opts ~f:(fun dst_pos -> try begin let check f = blit_was_called := false; slices_are_valid := Ok (); match Or_error.try_with f with | Error _ -> assert (not !blit_was_called); | Ok () -> ok_exn !slices_are_valid in check (fun () -> B.blito ~src:(Array.create src false) ?src_pos ?src_len ~dst:(Array.create dst false) ?dst_pos ()); check (fun () -> ignore (B.subo (Array.create src false) ?pos:src_pos ?len:src_len : bool array)); end with exn -> failwiths "failure" (exn, `src src, `src_pos src_pos, `src_len src_len, `dst dst, `dst_pos dst_pos) <:sexp_of< exn * [ `src of int ] * [ `src_pos of int option ] * [ `src_len of int option ] * [ `dst of int ] * [ `dst_pos of int option ] >>))))) ;; end core_kernel-113.00.00/src/blit.mli000066400000000000000000000001031256461164500165340ustar00rootroot00000000000000(** See {!Blit_intf} for documentation. *) include Blit_intf.Blit core_kernel-113.00.00/src/blit_intf.ml000066400000000000000000000136031256461164500174140ustar00rootroot00000000000000(** Standard type for [blit] functions, and reusable code for validating [blit] arguments. *) (** If [blit : (src, dst) blit], then [blit ~src ~src_pos ~len ~dst ~dst_pos] blits [len] values from [src] starting at position [src_pos] to [dst] at position [dst_pos]. Furthermore, [blit] raises if [src_pos], [len], and [dst_pos] don't specify valid slices of [src] and [dst]. *) type ('src, 'dst) blit = src : 'src -> src_pos : int -> dst : 'dst -> dst_pos : int -> len : int -> unit (** [blito] is like [blit], except that the [src_pos], [src_len], and [dst_pos] are optional (hence the "o" in "blito"). Also, we use [src_len] rather than [len] as a reminder that if [src_len] isn't supplied, then the default is to take the slice running from [src_pos] to the end of [src]. *) type ('src, 'dst) blito = src : 'src -> ?src_pos : int (** default is [0] *) -> ?src_len : int (** default is [length src - src_pos] *) -> dst : 'dst -> ?dst_pos : int (** default is [0] *) -> unit -> unit (** If [sub : (src, dst) sub], then [sub ~src ~pos ~len] returns a sequence of type [dst] containing [len] characters of [src] starting at [pos]. [subo] is like [sub], except [pos] and [len] are optional. *) type ('src, 'dst) sub = 'src -> pos:int -> len:int -> 'dst type ('src, 'dst) subo = ?pos : int (** default is [0] *) -> ?len : int (** default is [length src - pos] *) -> 'src -> 'dst module type S = sig type t val blit : (t, t) blit val blito : (t, t) blito val unsafe_blit : (t, t) blit val sub : (t, t) sub val subo : (t, t) subo end module type S_permissions = sig open Perms.Export type -'perms t val blit : ([> read] t, [> write] t) blit val blito : ([> read] t, [> write] t) blito val unsafe_blit : ([> read] t, [> write] t) blit val sub : ([> read] t, [< _ perms] t) sub val subo : ([> read] t, [< _ perms] t) subo end module type S1 = sig type 'a t val blit : ('a t, 'a t) blit val blito : ('a t, 'a t) blito val unsafe_blit : ('a t, 'a t) blit val sub : ('a t, 'a t) sub val subo : ('a t, 'a t) subo end module type S1_permissions = sig open Perms.Export type ('a, -'perms) t val blit : (('a, [> read]) t, ('a, [> write]) t) blit val blito : (('a, [> read]) t, ('a, [> write]) t) blito val unsafe_blit : (('a, [> read]) t, ('a, [> write]) t) blit val sub : (('a, [> read]) t, ('a, [< _ perms]) t) sub val subo : (('a, [> read]) t, ('a, [< _ perms]) t) subo end module type S_distinct = sig type src type dst val blit : (src, dst) blit val blito : (src, dst) blito val unsafe_blit : (src, dst) blit val sub : (src, dst) sub val subo : (src, dst) subo end (** Users of modules matching the blit signatures [S], [S1], and [S1_distinct] only need to understand the code above. The code below is only for those that need to implement modules that match those signatures. *) module type Elt = sig type t val equal : t -> t -> bool (** [of_bool] is used to generate two distinct values of type [t], used in unit tests. It is required that [of_bool false <> of_bool true]. *) val of_bool : bool -> t end module type Sequence = sig type elt type t with sexp_of val create : len:int -> t val length : t -> int val get : t -> int -> elt val set : t -> int -> elt -> unit end module type Blit = sig type nonrec ('src, 'dst) blit = ('src, 'dst) blit type nonrec ('src, 'dst) blito = ('src, 'dst) blito type nonrec ('src, 'dst) sub = ('src, 'dst) sub type nonrec ('src, 'dst) subo = ('src, 'dst) subo module type S = S module type S_permissions = S_permissions module type S1 = S1 module type S1_permissions = S1_permissions module type S_distinct = S_distinct (** There are various [Make*] functors that turn an [unsafe_blit] function into a [blit] function. The functors differ in whether the sequence type is monomorphic or polymorphic, and whether the src and dst types are distinct or are the same. The blit functions make sure the slices are valid and then call [unsafe_blit]. They guarantee at a call [unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len] that: {[ len > 0 && src_pos >= 0 && src_pos + len <= get_src_len src && dst_pos >= 0 && dst_pos + len <= get_dst_len dst ]} The [Make*] functors also automatically create unit tests. *) (** [Make] is for blitting between two values of the same monomorphic type. *) module Make (Elt : Elt) (Sequence : sig include Sequence with type elt := Elt.t val unsafe_blit : (t, t) blit end) : S with type t := Sequence.t (** [Make_distinct] is for blitting between values of distinct monomorphic types. *) module Make_distinct (Elt : Elt) (Src : Sequence with type elt := Elt.t) (Dst : sig include Sequence with type elt := Elt.t val unsafe_blit : (Src.t, t) blit end) : S_distinct with type src := Src.t with type dst := Dst.t (** [Make1] is for blitting between two values of the same polymorphic type. *) module Make1 (Sequence : sig type 'a t with sexp_of (** [Make1] guarantees to only call [create_like ~len t] with [len > 0] if [length t > 0]. *) val create_like : len:int -> 'a t -> 'a t val length : _ t -> int val unsafe_blit : ('a t, 'a t) blit (** [create], [get], and [set] are just used for unit tests. [z] is needed for [Flat_tuple_array]. *) type 'a z val create_bool : len:int -> bool z t val get : 'a z t -> int -> 'a val set : 'a z t -> int -> 'a -> unit end) : S1 with type 'a t := 'a Sequence.t end core_kernel-113.00.00/src/bool.ml000066400000000000000000000024561256461164500164010ustar00rootroot00000000000000open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std let invalid_argf = Core_printf.invalid_argf module T = struct type t = bool with bin_io, sexp, typerep let compare (t : t) t' = compare t t' (* we use physical equality here because for bools it is the same *) let equal (t : t) t' = t == t' let hash x = if x then 1 else 0 end include T let of_string = function | "true" -> true | "false" -> false | s -> invalid_argf "Bool.of_string: expected true or false but got %s" s () ;; let to_string = string_of_bool module Replace_polymorphic_compare = struct let min (x : t) y = if x < y then x else y let max (x : t) y = if x > y then x else y let compare = compare let ascending = compare let descending x y = compare y x let ( >= ) (x : t) y = x >= y let ( <= ) (x : t) y = x <= y let ( = ) = equal let equal = equal let ( > ) (x : t) y = x > y let ( < ) (x : t) y = x < y let ( <> ) (x : t) y = x != y let between t ~low ~high = low <= t && t <= high let _squelch_unused_module_warning_ = () end include Replace_polymorphic_compare (* Making bool hashable may seem frivolous, but consider an aggregate type with a bool in it that needs a custom hash function. *) include Hashable.Make (T) include Comparable.Map_and_set_binable (T) include Comparable.Validate (T) core_kernel-113.00.00/src/bool.mli000066400000000000000000000002461256461164500165450ustar00rootroot00000000000000type t = bool with bin_io, sexp, typerep open Interfaces include Comparable with type t := t include Hashable with type t := t include Stringable with type t := t core_kernel-113.00.00/src/bounded_int_table.ml000066400000000000000000000441351256461164500211070ustar00rootroot00000000000000open Std_internal module Array = Core_array module Entry = struct type ('key, 'data) t = { (* the int is fixed, but the 'key can change *) mutable key : 'key ; mutable data : 'data (* The index in [defined_entries] where this [Entry.t] is placed. *) ; mutable defined_entries_index : int; } with fields, sexp_of end type ('key, 'data) t_detailed = { num_keys : int ; sexp_of_key : ('key -> Sexp.t) option ; key_to_int : 'key -> int (* The number of entries in the table, not the length of the arrays below. *) ; mutable length : int (* [(key, data)] is in the table iff {[ entries_by_key.( key_to_int key ) = { key; data } ]} *) ; entries_by_key : ('key, 'data) Entry.t option array (* The first [length] elements of [defined_entries] hold the data in the table. This is an optimization for fold, to keep us from wasting iterations when the array is sparse. *) ; defined_entries : ('key, 'data) Entry.t option array } with fields, sexp_of type ('a, 'b) t = ('a, 'b) t_detailed type ('a, 'b) table = ('a, 'b) t let sexp_of_key t = match t.sexp_of_key with | Some f -> f | None -> fun key -> Int.sexp_of_t (t.key_to_int key) ;; let invariant invariant_key invariant_data t = try let num_keys = t.num_keys in assert (num_keys = Array.length t.entries_by_key); assert (num_keys = Array.length t.defined_entries); assert (0 <= t.length && t.length <= num_keys); Array.iteri t.entries_by_key ~f:(fun i -> function | None -> () | Some entry -> invariant_key entry.Entry.key; invariant_data entry.data; assert (i = t.key_to_int entry.key); match t.defined_entries.( entry.defined_entries_index ) with | None -> assert false | Some entry' -> assert (phys_equal entry entry')); Array.iteri t.defined_entries ~f:(fun i entry_opt -> match i < t.length, entry_opt with | false, None -> () | true, Some entry -> assert (i = entry.Entry.defined_entries_index) | _ -> assert false); let get_entries array = let a = Array.filter_opt array in Array.sort a ~cmp:(fun entry entry' -> Int.compare (t.key_to_int entry.Entry.key) (t.key_to_int entry'.key)); a in let entries = get_entries t.entries_by_key in let entries' = get_entries t.defined_entries in assert (t.length = Array.length entries); assert (Array.equal entries entries' ~equal:phys_equal) with exn -> let sexp_of_key = sexp_of_key t in failwiths "invariant failed" (exn, t) <:sexp_of< exn * (key, _) t_detailed >> ;; let debug = ref false let check_invariant t = if !debug then invariant ignore ignore t let is_empty t = length t = 0 let create ?sexp_of_key ~num_keys ~key_to_int () = if num_keys < 0 then failwiths "num_keys must be nonnegative" num_keys <:sexp_of< int >>; let t = { num_keys ; sexp_of_key ; key_to_int ; length = 0 ; entries_by_key = Array.create ~len:num_keys None ; defined_entries = Array.create ~len:num_keys None } in check_invariant t; t ;; let create_like { num_keys ; sexp_of_key ; key_to_int ; length = _ ; entries_by_key = _ ; defined_entries = _ } = create ~num_keys ?sexp_of_key ~key_to_int () ;; let fold t ~init ~f = let rec loop i ac = if i = t.length then ac else match t.defined_entries.( i ) with | None -> assert false | Some entry -> loop (i + 1) (f ~key:entry.key ~data:entry.data ac) in loop 0 init ;; let iter t ~f = fold t ~init:() ~f:(fun ~key ~data () -> f ~key ~data) let iter_vals t ~f = iter t ~f:(fun ~key:_ ~data -> f data) let map_entries t ~f = fold t ~init:[] ~f:(fun ~key ~data ac -> f ~key ~data :: ac) let to_alist t = map_entries t ~f:(fun ~key ~data -> (key, data)) let clear t = for i = 0 to t.length - 1 do match t.defined_entries.( i ) with | None -> assert false | Some entry -> t.defined_entries.( i ) <- None; t.entries_by_key.( t.key_to_int entry.key ) <- None; done; t.length <- 0; ;; module Serialized = struct type ('key, 'data) t = { num_keys : int ; alist : ('key * 'data) list } with bin_io, sexp end let to_serialized t = { Serialized. num_keys = t.num_keys ; alist = to_alist t } ;; let sexp_of_t sexp_of_key sexp_of_data t = Serialized.sexp_of_t sexp_of_key sexp_of_data (to_serialized t) ;; let keys t = map_entries t ~f:(fun ~key ~data:_ -> key) let data t = map_entries t ~f:(fun ~key:_ ~data -> data) let entry_opt t key = let index = t.key_to_int key in try t.entries_by_key.( index ) with _ -> let sexp_of_key = sexp_of_key t in failwiths "key's index out of range" (key, index, `Should_be_between_0_and (t.num_keys - 1)) <:sexp_of< key * int * [ `Should_be_between_0_and of int ] >> ;; let find t key = Option.map (entry_opt t key) ~f:Entry.data let find_exn t key = match entry_opt t key with | Some entry -> Entry.data entry | None -> let sexp_of_key = sexp_of_key t in failwiths "Bounded_int_table.find_exn got unknown key" (key, t) <:sexp_of< key * (key, _) t >> ;; let mem t key = is_some (entry_opt t key) let add_assuming_not_there t ~key ~data = let defined_entries_index = t.length in let entry_opt = Some { Entry. key; data; defined_entries_index } in t.entries_by_key.( t.key_to_int key ) <- entry_opt; t.defined_entries.( defined_entries_index ) <- entry_opt; t.length <- t.length + 1; check_invariant t; ;; let find_or_add t key ~default = match entry_opt t key with | Some e -> Entry.data e | None -> let data = default () in add_assuming_not_there t ~key ~data; data ;; let set t ~key ~data = match entry_opt t key with | None -> add_assuming_not_there t ~key ~data | Some entry -> entry.key <- key; (* we update the key because we want the latest key in the table *) entry.data <- data; ;; let add t ~key ~data = match entry_opt t key with | Some entry -> `Duplicate entry.Entry.data | None -> add_assuming_not_there t ~key ~data; `Ok ;; let add_exn t ~key ~data = match add t ~key ~data with | `Ok -> () | `Duplicate _ -> let sexp_of_key = sexp_of_key t in failwiths "Bounded_int_table.add_exn of key whose index is already present" (key, t.key_to_int key) <:sexp_of< key * int >> ;; let remove t key = begin match entry_opt t key with | None -> () | Some entry -> t.length <- t.length - 1; t.entries_by_key.( t.key_to_int key ) <- None; let hole = entry.defined_entries_index in let last = t.length in if hole < last then begin match t.defined_entries.( last ) with | None -> let sexp_of_key = sexp_of_key t in failwiths "Bounded_int_table.remove bug" (key, last, t) <:sexp_of< key * int * (key, _) t_detailed >> | Some entry_to_put_in_hole as entry_to_put_in_hole_opt -> t.defined_entries.( hole ) <- entry_to_put_in_hole_opt; entry_to_put_in_hole.defined_entries_index <- hole; end; t.defined_entries.( last ) <- None; end; check_invariant t; ;; let existsi t ~f = with_return (fun r -> iter t ~f:(fun ~key ~data -> if f ~key ~data then r.return true); false) ;; let exists t ~f = existsi t ~f:(fun ~key:_ ~data -> f data) let for_alli t ~f = not (existsi t ~f:(fun ~key ~data -> not (f ~key ~data))) let for_all t ~f = for_alli t ~f:(fun ~key:_ ~data -> f data) let equal key_equal data_equal t1 t2 = length t1 = length t2 && for_alli t1 ~f:(fun ~key ~data -> match entry_opt t2 key with | None -> false | Some entry -> key_equal key entry.Entry.key && data_equal data entry.Entry.data) ;; (* test [exists{,i}], [for_all{,i}] *) TEST_MODULE = struct let of_list keys = let t = create ~num_keys:10 ~key_to_int:Fn.id ~sexp_of_key:Int.sexp_of_t () in List.iter keys ~f:(fun key -> add_exn t ~key ~data:key); t ;; let test_exists_like_function exists = exists (of_list []) ~f:(fun _ -> assert false) = false && exists (of_list [1]) ~f:(fun _ -> false) = false && exists (of_list [1]) ~f:(fun _ -> true) = true && exists (of_list [1]) ~f:(fun data -> data = 1) = true && exists (of_list [1; 2; 3]) ~f:(fun _ -> false) = false && exists (of_list [1; 2; 3]) ~f:(fun _ -> true) = true && exists (of_list [1; 2; 3]) ~f:(fun data -> data = 3) = true ;; TEST = test_exists_like_function (fun t ~f -> existsi t ~f:(fun ~key:_ ~data -> f data)) TEST = test_exists_like_function exists TEST = test_exists_like_function (fun t ~f -> not (for_alli t ~f:(fun ~key:_ ~data -> not (f data)))) ;; TEST = test_exists_like_function (fun t ~f -> not (for_all t ~f:(fun data -> not (f data)))); ;; let equal_of_list l1 l2 = equal Int.equal Int.equal (of_list l1) (of_list l2) TEST = equal_of_list [] [] = true TEST = equal_of_list [] [1] = false TEST = equal_of_list [1] [] = false TEST = equal_of_list [1] [1] = true TEST = equal_of_list [1] [1; 2] = false TEST = equal_of_list [1; 2] [1; 2] = true TEST = equal_of_list [1; 2] [2; 1] = true (* test [equal] between tables that have different [to_int] functions. *) TEST_UNIT = let of_list ~offset keys = let t = create ~num_keys:10 ~key_to_int:(fun i -> i + offset) () in List.iter keys ~f:(fun key -> add_exn t ~key ~data:key); t in let t0 = of_list [ 1; 2 ] ~offset:0 in let t1 = of_list [ 1; 2 ] ~offset:1 in let t2 = of_list [ 1; 2 ] ~offset:2 in let t3 = of_list [ 2; 3 ] ~offset:0 in let equal = equal Int.equal Int.equal in assert (equal t0 t1); assert (equal t0 t2); assert (equal t1 t2); assert (not (equal t0 t3)); assert (not (equal t1 t3)); assert (not (equal t2 t3)); ;; end module With_key (Key : sig type t with bin_io, sexp val to_int : t -> int end) = struct type 'data t = (Key.t, 'data) table type 'data table = 'data t let create ~num_keys = create ~sexp_of_key:Key.sexp_of_t ~num_keys ~key_to_int:Key.to_int () ;; let of_alist_exn alist = let max_key = List.fold alist ~init:(-1) ~f:(fun max (key, _) -> Int.max max (Key.to_int key)) in let t = create ~num_keys:(max_key + 1) in List.iter alist ~f:(fun (key, data) -> add_exn t ~key ~data); t ;; let of_alist alist = Or_error.try_with (fun () -> of_alist_exn alist) let sexp_of_t sexp_of_data = sexp_of_t Key.sexp_of_t sexp_of_data let of_serialized { Serialized. num_keys; alist } = let t = create ~num_keys in List.iter alist ~f:(fun (key, data) -> add_exn t ~key ~data); t ;; let t_of_sexp data_of_sexp sexp = of_serialized (Serialized.t_of_sexp Key.t_of_sexp data_of_sexp sexp) ;; include Binable.Of_binable1 (struct type 'data t = (Key.t, 'data) Serialized.t with bin_io end) (struct type 'data t = 'data table let to_binable = to_serialized let of_binable = of_serialized end) end (* test [With_key] *) TEST_MODULE = struct include (With_key (Int)) TEST = is_empty (create ~num_keys:1) TEST = Result.is_ok (of_alist [ ]) TEST = Result.is_ok (of_alist [ (1, 1) ]) TEST = Result.is_error (of_alist [ (1, 1); (1, 2) ]) TEST = is_empty (of_alist_exn []) TEST_UNIT = let t = of_alist_exn [ (1, 2) ] in assert (length t = 1); assert (keys t = [1]); assert (data t = [2]); ;; TEST_UNIT = let t = of_alist_exn [ (1, 2); (3, 4) ] in assert (length t = 2); assert (keys t = [1; 3] || keys t = [3; 1]); assert (data t = [2; 4] || data t = [4; 2]); ;; end let filter_mapi t ~f = let result = create_like t in iter t ~f:(fun ~key ~data -> match f ~key ~data with | None -> () | Some data -> add_exn result ~key ~data); result ;; let ignore_key f = fun ~key:_ ~data -> f data let filter_map t ~f = filter_mapi t ~f:(ignore_key f) let mapi t ~f = filter_mapi t ~f:(fun ~key ~data -> Some (f ~key ~data)) let map t ~f = mapi t ~f:(ignore_key f) TEST_MODULE = struct include (With_key (Int)) let equal = equal Int.equal Int.equal let test_filter_map input ~f expect = equal (filter_map (of_alist_exn input) ~f) (of_alist_exn expect) ;; TEST = test_filter_map [] ~f:(fun _ -> assert false) [] TEST = test_filter_map [1, 2] ~f:(fun _ -> None) [] TEST = test_filter_map [1, 2] ~f:(fun x -> Some x) [1, 2] TEST = test_filter_map [1, 2] ~f:(fun x -> Some (x + 1)) [1, 3] TEST = test_filter_map [(1, 2); (3, 4)] ~f:(fun x -> if x = 2 then Some x else None) [1, 2] ;; let test_map_like map = let test input ~f expect = equal (map (of_alist_exn input) ~f) (of_alist_exn expect) in test [] ~f:(fun _ -> assert false) [] && test [(1, 2)] ~f:((+) 3) [(1, 5)] && test [(1, 2); (3, 4)] ~f:((+) 5) [(1, 7); (3, 9)] ;; TEST = test_map_like (fun t ~f -> mapi t ~f:(fun ~key:_ ~data -> f data)) TEST = test_map_like map end TEST_MODULE = struct let () = debug := true TEST_UNIT = (* Check that [set] replaces the key. *) let t = create ~num_keys:1 ~key_to_int:(fun _ -> 0) () in set t ~key:13 ~data:(); set t ~key:14 ~data:(); assert (keys t = [14]); ;; let create ~num_keys : (int, _) t = create ~num_keys ~key_to_int:Fn.id () let assert_empty t = assert (length t = 0); assert (to_alist t = []); assert (keys t = []); assert (data t = []); for i = 0 to t.num_keys - 1 do assert (Option.is_none t.entries_by_key.( i )); assert (Option.is_none t.defined_entries.( i )); done ;; TEST_UNIT = begin try ignore (create ~num_keys:(-1)); assert false with _ -> () end; TEST_UNIT = ignore (create ~num_keys:0) TEST_UNIT = ignore (create ~num_keys:1) TEST_UNIT = ignore (create ~num_keys:10_000) TEST_UNIT = let num_keys = 10 in let t = create ~num_keys in let key_is_valid key = try ignore (find t key); true with _ -> false in assert (not (key_is_valid (-1))); for key = 0 to num_keys - 1 do assert (key_is_valid key); assert (is_none (find t key)); done; assert (not (key_is_valid num_keys)); assert_empty t; ;; let table_data = data TEST_UNIT = let num_keys = 10 in let t = create ~num_keys in let key = 0 in let data = "zero" in add_exn t ~key ~data; assert (length t = 1); assert (find t key = Some data); for key = 1 to num_keys - 1 do assert (find t key = None) done; assert (to_alist t = [(key, data)]); assert (keys t = [key]); assert (table_data t = [data]); remove t key; assert_empty t; ;; TEST_UNIT = let num_keys = 10 in let t = create ~num_keys in let key = 0 in let data = "zero" in add_exn t ~key ~data:"bad"; set t ~key ~data; assert (find t key = Some data); for key = 1 to num_keys - 1 do assert (find t key = None) done; assert (to_alist t = [(key, data)]); assert (keys t = [key]); assert (table_data t = [data]); ;; TEST_UNIT = let num_keys = 10 in let t = create ~num_keys in for key = 1 to 5 do add_exn t ~key ~data:(Int.to_string key) done; assert (length t = 5); for key = 1 to 5 do remove t key; done; assert_empty t; ;; TEST_UNIT = let num_keys = 10 in let t = create ~num_keys in for key = 0 to num_keys - 1 do add_exn t ~key ~data:(Int.to_string key) done; assert (length t = num_keys); for key = 0 to num_keys - 1 do remove t key; done; assert_empty t; ;; (* Additional tests for [with binio], [with sexp], [t_of_sexp], [filter_map{,i}], [map{,i}]. *) TEST_UNIT = let outer_sexp_of_t = sexp_of_t in let module M = struct module Table = With_key (Int) type alist = (int * int) list with sexp_of type t = int Table.t with sexp_of end in let open M in let empty = Table.of_alist_exn [] in let equal = equal Int.equal Int.equal in for n = 0 to 5 do let alist = List.init n ~f:(fun i -> (i, i)) in let t = Table.of_alist_exn alist in assert (equal t t); List.iter alist ~f:(fun (key', data') -> assert (existsi t ~f:(fun ~key ~data -> key = key' && data = data')); assert (exists t ~f:(fun data -> data = data'))); assert (for_alli t ~f:(fun ~key ~data -> key = data)); assert (for_all t ~f:(fun data -> 0 <= data && data < n)); let sort alist = List.sort alist ~cmp:(fun (i, _) (i', _) -> compare i i') in let alist' = sort (to_alist t) in if alist <> alist' then failwiths "Bounded_int_table alist bug" (t, alist, alist') <:sexp_of< t * alist * alist >>; let sexp = sexp_of_t t in let sexp' = outer_sexp_of_t Int.sexp_of_t Int.sexp_of_t t in if sexp <> sexp' then failwiths "Bounded_int_table sexp bug" (t, sexp, sexp') <:sexp_of< t * Sexp.t * Sexp.t >>; let ensure_equal message t t' = if not (equal t t') then failwiths "Bounded_int_table bug" (message, t, t') <:sexp_of< string * t * t >>; in ensure_equal "t_of_sexp" t (Table.t_of_sexp Int.t_of_sexp sexp); ensure_equal "filter_mapi" t (filter_mapi t ~f:(fun ~key ~data:_ -> Some key)); ensure_equal "filter_map" t (filter_map t ~f:(fun data -> Some data)); ensure_equal "filter_map None" empty (filter_map t ~f:(fun _ -> None)); ensure_equal "map" t (map t ~f:Fn.id); ensure_equal "mapi" t (mapi t ~f:(fun ~key:_ ~data -> data)); ensure_equal "map and mapi" (map t ~f:(fun x -> x + 1)) (mapi t ~f:(fun ~key:_ ~data -> data + 1)); let module T = struct type t = int Table.t with bin_io, sexp end in let binable_m = (module T : Binable.S with type t = T.t) in ensure_equal "binio" t (Binable.of_string binable_m (Binable.to_string binable_m t)) done; ;; (* Test [clear] *) TEST_UNIT = let num_keys = 10 in let t = create ~num_keys in clear t; add_exn t ~key:5 ~data:"five"; assert (length t = 1); assert (find t 5 = Some "five"); clear t; assert_empty t; for key = 0 to num_keys - 1 do add_exn t ~key ~data:(Int.to_string key) done; assert (length t = num_keys); clear t; assert_empty t; ;; end core_kernel-113.00.00/src/bounded_int_table.mli000066400000000000000000000104771256461164500212620ustar00rootroot00000000000000(** A [Bounded_int_table] is a table whose keys can be mapped to integers in a fixed range, 0 ... num_keys-1, where [num_keys] is specified at table-creation time. The purpose of [Bounded_int_table] is to be faster than [Hashtbl] in situations where one is willing to pay a space cost for the speed. [Bounded_int_table] presents a subset of the [Hashtbl] interface. The key type can be any type, but table creation requires a [key_to_int] function, which will be used to extract the integer of all keys. If multiple keys map to the same integer, then only one of them can be in the table at a time. Any operation that supplies a key whose corresponding integer is outside the allowed range for the table will cause an exception. A [Bounded_int_table] is implemented using two fixed size arrays of size [num_keys], which are supplied at table-creation time. The space used does not depend on the [length] of the table but rather only on [num_keys]. Operations that deal with a single element (find, mem, add, remove, set) take constant time, and perform one or two array operations. Operations that deal with all of the keys defined in the table (data, fold, iter, iter_vals, keys, to_alist) take time proportional to the [length] of the table, not [num_keys]. *) open Std_internal type ('key, 'data) t with sexp_of type ('a, 'b) table = ('a, 'b) t include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t (** Equality only requires the keys and values to be the same, not the bin or sexp formatting or the integers the keys correspond to (see [key_to_int]).*) include Equal.S2 with type ('a, 'b) t := ('a, 'b) t (** [create ~num_keys ~key_to_int] returns a table where the keys can map to 0 .. num_keys-1, according to [key_to_int]. It is an error if [num_keys < 0]. [sexp_of_key], if supplied, will be used to display keys in error messages. *) val create : ?sexp_of_key : ('key -> Sexp.t) -> num_keys : int -> key_to_int : ('key -> int) -> unit -> ('key, 'data) t (** Standard hashtbl functions. *) val keys : ('key, _ ) t -> 'key list val data : (_ , 'data) t -> 'data list val find : ('key, 'data) t -> 'key -> 'data option val find_exn : ('key, 'data) t -> 'key -> 'data val find_or_add : ('key, 'data) t -> 'key -> default:(unit -> 'data) -> 'data val fold : ('key, 'data) t -> init : 'accum -> f : (key:'key -> data:'data -> 'accum -> 'accum) -> 'accum val iter : ('key, 'data) t -> f:(key:'key -> data:'data -> unit) -> unit val iter_vals : (_ , 'data) t -> f:( 'data -> unit) -> unit val filter_mapi : ('key, 'data1) t -> f : (key:'key -> data:'data1 -> 'data2 option) -> ('key, 'data2) t val filter_map : ('key, 'data1) t -> f : ('data1 -> 'data2 option) -> ('key, 'data2) t val mapi : ('key, 'data1) t -> f:(key:'key -> data:'data1 -> 'data2) -> ('key, 'data2) t val map : ('key, 'data1) t -> f:( 'data1 -> 'data2) -> ('key, 'data2) t val for_alli : ('key, 'data) t -> f:(key:'key -> data:'data -> bool) -> bool val existsi : ('key, 'data) t -> f:(key:'key -> data:'data -> bool) -> bool val for_all : (_ , 'data) t -> f:( 'data -> bool) -> bool val exists : (_ , 'data) t -> f:( 'data -> bool) -> bool val length : (_, _) t -> int val mem : ('key, _) t -> 'key -> bool val remove : ('key, _) t -> 'key -> unit val set : ('a, 'b) t -> key:'a -> data:'b -> unit val add : ('a, 'b) t -> key:'a -> data:'b -> [ `Ok | `Duplicate of 'b ] val add_exn : ('a, 'b) t -> key:'a -> data:'b -> unit val to_alist : ('key, 'data) t -> ('key * 'data) list val clear : (_, _) t -> unit module With_key (Key : sig type t with bin_io, sexp val to_int : t -> int end) : sig (** Serialization of a bounded int table using [bin_io] or [sexp] preserves [num_keys], but only takes space proportional to the [length] of the table. *) type 'data t = (Key.t, 'data) table with bin_io, sexp val create : num_keys:int -> 'data t (** [of_alist] returns a table whose maximum allowed key is the maximum key in the input list. *) val of_alist : (Key.t * 'data) list -> 'data t Or_error.t val of_alist_exn : (Key.t * 'data) list -> 'data t end (** set [debug := true] to turn on debugging, including potentially slow invariant checking. *) val debug : bool ref core_kernel-113.00.00/src/bucket.ml000066400000000000000000000045371256461164500167250ustar00rootroot00000000000000open Std_internal module type Contents = sig type t with bin_io, sexp include Comparable with type t := t val zero : t val (+) : t -> t -> t val (-) : t -> t -> t end module type S = sig type contents type t with bin_io, sexp (* Fails if init_level is not within bounds [zero;size]. *) val create : size:contents -> init_level:contents -> t (* the size used upon creation *) val size : t -> contents (* the current bucket level *) val level : t -> contents (* Take some exact amount out of the bucket and return `Taken. If there is not enough * left in the bucket, return `Unable and do not take anything *) val take : t -> contents -> [ `Taken | `Unable ] (* Take some amount out of the bucket, possibly emptying it. The return value is the * amount that was actually taken out. *) val take_at_most : t -> contents -> contents (* Add some amount into the bucket. Cap at maximum capacity if the increment provided is too big *) val fill : t -> contents -> unit end module Make (C: Contents): (S with type contents = C.t) = struct type contents = C.t with sexp, bin_io type t = { mutable level : contents; size : contents; } with sexp, bin_io let create ~size ~init_level = let error msg = failwithf "Bucket.create ~size:%s ~init_level:%s: %s" (Sexp.to_string (C.sexp_of_t size)) (Sexp.to_string (C.sexp_of_t init_level)) msg (); in if C.(<) init_level C.zero then error "init_level negative"; if C.(>) init_level size then error "init_level above bucket size"; { level = init_level; size = size } ;; let size t = t.size let level t = t.level let assert_positive name x = if C.(<) x C.zero then invalid_argf "Bucket.%s %s < 0" name (Sexp.to_string (C.sexp_of_t x)) () let take t x = assert_positive "take" x; let new_level = C.(-) t.level x in if C.(<) new_level C.zero then `Unable else begin t.level <- new_level; `Taken end let take_at_most t x = assert_positive "take_at_most" x; let old_level = t.level in t.level <- C.max C.zero (C.(-) old_level x); C.(-) old_level t.level let fill t x = assert_positive "fill" x; let old_level = t.level in t.level <- C.min t.size (C.(+) old_level x) end module Int = Make (Int) module Int64 = Make (Int64) module Float = Make (Float) core_kernel-113.00.00/src/byte_units.ml000066400000000000000000000113471256461164500176320ustar00rootroot00000000000000(* Conversions between units of measure based on bytes. *) open Std_internal let bytes_per_word = let module W = Word_size in match W.word_size with | W.W32 -> 4. | W.W64 -> 8. ;; let kbyte = 1024. let mbyte = kbyte *. kbyte let gbyte = kbyte *. mbyte (* External.t - used just for custom sexp converters *) module External = struct type t = [ | `Bytes of float | `Kilobytes of float | `Megabytes of float | `Gigabytes of float | `Words of float ] with sexp end module Measure = struct type t = [ `Bytes | `Kilobytes | `Megabytes | `Gigabytes | `Words ] with sexp, bin_io let bytes = function | `Bytes -> 1. | `Kilobytes -> kbyte | `Megabytes -> mbyte | `Gigabytes -> gbyte | `Words -> bytes_per_word ;; end module T = struct type t = float with bin_io, compare let hash = Float.hash let scale = Float.( * ) module Infix = struct open Float let ( - ) = ( - ) let ( + ) = ( + ) let ( / ) = ( / ) let ( // ) = ( / ) end let largest_measure t = (* We never select words as the largest measure *) if Float.( > ) t gbyte then `Gigabytes else if Float.( > ) t mbyte then `Megabytes else if Float.( > ) t kbyte then `Kilobytes else `Bytes let number_of_measures t measure = t /. Measure.bytes measure let create m n = n *. Measure.bytes m let externalize t = let used_measure = largest_measure t in let n = number_of_measures t used_measure in match used_measure with | `Bytes -> `Bytes n | `Kilobytes -> `Kilobytes n | `Megabytes -> `Megabytes n | `Gigabytes -> `Gigabytes n | `Words -> `Words n ;; let internalize t = match t with | `Bytes n -> create `Bytes n | `Kilobytes n -> create `Kilobytes n | `Megabytes n -> create `Megabytes n | `Gigabytes n -> create `Gigabytes n | `Words n -> create `Words n ;; let bytes t = t let of_string s = let length = String.length s in if length < 2 then invalid_argf "'%s' passed to Byte_units.of_string - too short" s (); let base_str = String.sub s ~pos:0 ~len:(length - 1) in let ext_char = Char.lowercase s.[length - 1] in let base = try Float.of_string base_str with | _ -> invalid_argf "'%s' passed to Byte_units.of_string - %s cannot be \ converted to float " s base_str () in let measure = match ext_char with | 'b' -> `Bytes | 'k' -> `Kilobytes | 'm' -> `Megabytes | 'g' -> `Gigabytes | 'w' -> `Words | ext -> invalid_argf "'%s' passed to Byte_units.of_string - illegal \ extension %c" s ext () in create measure base ;; let t_of_sexp sexp = match sexp with | Sexp.Atom s -> (try of_string s with Invalid_argument msg -> of_sexp_error msg sexp) | Sexp.List _ -> internalize (External.t_of_sexp sexp) ;; let sexp_of_t t = External.sexp_of_t (externalize t) let kilobytes t = bytes t /. kbyte let megabytes t = bytes t /. mbyte let gigabytes t = bytes t /. gbyte let words t = bytes t /. bytes_per_word let to_string_with_measure measure t = let ext = match measure with | `Bytes -> 'b' | `Kilobytes -> 'k' | `Megabytes -> 'm' | `Gigabytes -> 'g' | `Words -> 'w' in sprintf "%g%c" (number_of_measures t measure) ext ;; let to_string_hum ?measure t = let measure = match measure with | Some m -> m | None -> largest_measure t in to_string_with_measure measure t ;; let to_string t = to_string_hum t end include T include Comparable.Make (T) include Hashable.Make (T) TEST_MODULE "{of,to}_string" = struct let f measure input expected_output = let observed_output = match measure with | `Specific measure -> to_string_hum ~measure (of_string input) | `Largest -> to_string_hum (of_string input) in let result = String.equal expected_output observed_output in if not result then begin let measure = <:sexp_of<[ `Specific of Measure.t | `Largest ]>> measure |! Sexp.to_string in eprintf "\n(%s) %s -> %s != %s\n%!" measure input expected_output observed_output end; result TEST = f `Largest "3b" "3b" TEST = f `Largest "3w" (sprintf "%gb" (3.0 *. bytes_per_word)) TEST = f `Largest "3k" "3k" TEST = f `Largest "3m" "3m" TEST = f `Largest "3g" "3g" TEST = f (`Specific `Bytes) "3k" "3072b" TEST = f (`Specific `Kilobytes) "3k" "3k" TEST = f (`Specific `Megabytes) "3k" "0.00292969m" TEST = f (`Specific `Gigabytes) "3k" "2.86102e-06g" TEST = f (`Specific `Words) "3k" (sprintf "%gw" ((3.0 *. kbyte) /. bytes_per_word)) end core_kernel-113.00.00/src/byte_units.mli000066400000000000000000000022051256461164500177740ustar00rootroot00000000000000(** Conversions between units of measure based on bytes. *) module Measure : sig type t = [ `Bytes | `Kilobytes | `Megabytes | `Gigabytes | `Words ] with sexp, bin_io end type t with bin_io, sexp (** [create measure value] creates a [t] from [value] units of the given measure. *) val create : Measure.t -> float -> t include Comparable.S with type t := t include Hashable .S with type t := t include Stringable.S with type t := t (** [to_string_hum ?measure t] returns a string representation of [t]. If [measure] is not given then the largest measure (excluding [`Words]) is used that causes the translated value to exceed 1. *) val to_string_hum : ?measure:Measure.t -> t -> string val bytes : t -> float val kilobytes : t -> float val megabytes : t -> float val gigabytes : t -> float val words : t -> float (** [scale t mul] scale the measure [t] by [mul] *) val scale : t -> float -> t module Infix : sig val ( - ) : t -> t -> t val ( + ) : t -> t -> t (** [( / ) t mul] scales [t] by [1/mul] *) val (/) : t -> float -> t (** [( // ) t1 t2] returns the ratio of t1 to t2 *) val (//) : t -> t -> float end core_kernel-113.00.00/src/caml.ml000066400000000000000000000021601256461164500163520ustar00rootroot00000000000000(* The Caml module binds everything that is available in the standard environment so that we can easily refer to standard things even if they've been rebound. *) module Arg = Arg module Array = Array module ArrayLabels = ArrayLabels module Buffer = Buffer module Bytes = Bytes module Callback = Callback module Char = Char module Complex = Complex module Digest = Digest module Filename = Filename module Format = Format module Gc = Gc module Genlex = Genlex module Hashtbl = Hashtbl module Int32 = Int32 module Int64 = Int64 module Lazy = Lazy module Lexing = Lexing module List = List module ListLabels = ListLabels module Map = Map module Marshal = Marshal module MoreLabels = MoreLabels module Nativeint = Nativeint module Oo = Oo module Parsing = Parsing module Pervasives = Pervasives module Printexc = Printexc module Printf = Printf module Queue = Queue module Random = Random module Scanf = Scanf module Set = Set module Sort = Sort module Stack = Stack module StdLabels = StdLabels module Stream = Stream module String = String module StringLabels = StringLabels module Sys = Sys module Weak = Weak include Pervasives core_kernel-113.00.00/src/common.ml000066400000000000000000000062111256461164500167270ustar00rootroot00000000000000open Sexplib.Conv let seek_out _ _ = `Deprecated_use_out_channel let pos_out _ = `Deprecated_use_out_channel let out_channel_length _ = `Deprecated_use_out_channel let seek_in _ _ = `Deprecated_use_in_channel let pos_in _ = `Deprecated_use_in_channel let in_channel_length _ = `Deprecated_use_in_channel let modf _ = `Deprecated_use_float_modf let truncate _ = `Deprecated_use_float_iround_towards_zero let ( & ) _ _ = `Deprecated_use_two_ampersands let ( or ) = `Deprecated_use_pipe_pipe let max_int = `Deprecated_use_int_module let min_int = `Deprecated_use_int_module let ceil _ = `Deprecated_use__Float__round_up let floor _ = `Deprecated_use__Float__round_down let abs_float _ = `Deprecated_use_float_module let mod_float _ = `Deprecated_use_float_module let frexp _ _ = `Deprecated_use_float_module let ldexp _ _ = `Deprecated_use_float_module let float_of_int _ = `Deprecated_use_float_module let max_float = `Deprecated_use_float_module let min_float = `Deprecated_use_float_module let epsilon_float = `Deprecated_use_float_module let classify_float _ = `Deprecated_use_float_module let string_of_float _ = `Deprecated_use_float_module let float_of_string _ = `Deprecated_use_float_module let infinity = `Deprecated_use_float_module let neg_infinity = `Deprecated_use_float_module let nan = `Deprecated_use_float_module let int_of_float _ = `Deprecated_use_float_module type fpclass = [`Deprecated_use_float_module ] let close_in _ = `Deprecated_use_in_channel let close_out _ = `Deprecated_use_out_channel include Perms.Export include Never_returns exception Finally = Exn.Finally let protectx = Exn.protectx let protect = Exn.protect let (|!) = Fn.(|!) let (|>) = Fn.(|>) let ident = Fn.id let const = Fn.const let (==>) a b = (not a) || b let uw = function Some x -> x | None -> raise Not_found let is_none = Option.is_none let is_some = Option.is_some let fst3 (x,_,_) = x let snd3 (_,y,_) = y let trd3 (_,_,z) = z let ok_exn = Or_error.ok_exn let error = Or_error.error let failwiths = Error.failwiths let failwithp = Error.failwithp include struct open Core_printf let failwithf = failwithf let invalid_argf = invalid_argf end (* module With_return only exists to avoid circular dependencies *) include With_return let phys_equal = Caml.(==) let (==) _ _ = `Consider_using_phys_equal let (!=) _ _ = `Consider_using_phys_equal let phys_same (type a) (type b) (a : a) (b : b) = phys_equal a (Obj.magic b : a) TEST_MODULE "phys_same" = struct TEST = phys_same 0 None TEST = phys_same 1 true TEST = let f () = "statically-allocated" in phys_same (f ()) (f ()) ;; TEST = let a = (1, 2) in phys_same a a ;; type thing = Obscure : _ -> thing let same_thing (Obscure a) (Obscure b) = phys_same a b TEST = let a = (1, 2) in same_thing (Obscure a) (Obscure a) ;; end let force = Lazy.force let stage = Staged.stage let unstage = Staged.unstage exception Bug of string with sexp exception C_malloc_exn of int * int (* errno, size *) let () = Callback.register_exception "C_malloc_exn" (C_malloc_exn (0, 0)); core_kernel-113.00.00/src/common.mli000066400000000000000000000174621256461164500171120ustar00rootroot00000000000000(** Basic types and definitions required throughout the system. *) open Sexplib exception Bug of string (** Raised when finalization after an exception failed, too. The first exception argument is the one raised by the initial function, the second exception the one raised by the finalizer. *) exception Finally of exn * exn (** Types for expressing read-write permissions in phantom types. See the [Perms] module for details. *) include module type of Perms.Export (** [never_returns] should be used as the return type of functions that don't return and might block forever, rather than ['a] or [_]. This forces callers of such functions to have a call to [never_returns] at the call site, which makes it clear to readers what's going on. We do not intend to use this type for functions such as [failwithf] that always raise an exception. *) type never_returns = Never_returns.never_returns with sexp_of val never_returns : never_returns -> _ (** {6 Error handling} *) (** See exn.mli *) val protect : f:(unit -> 'a) -> finally:(unit -> unit) -> 'a val protectx : f:('b -> 'a) -> 'b -> finally:('b -> unit) -> 'a (** {6 Input Output}*) (**{6 triple handling }*) val fst3 : ('a * _ * _ ) -> 'a val snd3 : (_ * 'a * _ ) -> 'a val trd3 : (_ * _ * 'a) -> 'a (** {6 Option handling} *) val uw : 'a option -> 'a val is_none : 'a option -> bool val is_some : 'a option -> bool (** {6 Functions from fn.ml} *) val (|!) : 'a -> ('a -> 'b) -> 'b val (|>) : 'a -> ('a -> 'b) -> 'b val ident : 'a -> 'a val const : 'a -> _ -> 'a val (==>) : bool -> bool -> bool (** [Error.failwiths] *) val failwiths : ?strict : unit -> ?here:Lexing.position -> string -> 'a -> ('a -> Sexp.t) -> _ (** [Error.failwithp] *) val failwithp : ?strict : unit -> Lexing.position -> string -> 'a -> ('a -> Sexp.t) -> _ val failwithf : ('r, unit, string, unit -> _) format4 -> 'r val invalid_argf : ('r, unit, string, unit -> _) format4 -> 'r (** [Or_error.ok_exn] *) val ok_exn : 'a Or_error.t -> 'a (** [Or_error.error] *) val error : ?strict : unit -> string -> 'a -> ('a -> Sexp.t) -> _ Or_error.t (** [with_return f] allows for something like the return statement in C within [f]. There are three ways [f] can terminate: 1. If [f] calls [r.return x], then [x] is returned by [with_return]. 2. If [f] evaluates to a value [x], then [x] is returned by [with_return]. 3. If [f] raises an exception, it escapes [with_return]. Here is a typical example: {[ let find l ~f = with_return (fun r -> List.iter l ~f:(fun x -> if f x then r.return (Some x)); None ) ]} It is only because of a deficiency of ML types that [with_return] doesn't have type: {[ val with_return : 'a. (('a -> ('b. 'b)) -> 'a) -> 'a ]} but we can slightly increase the scope of 'b, without changing the meaning of the type and then we get {[ type 'a return = { return : 'b . 'a -> 'b } val with_return : ('a return -> 'a) -> 'a ]} But the actual reason we chose to use a record type with polymorphic field is that otherwise we would have to clobber the namespace of functions with [return] and that is undesirable because [return] would get hidden as soon as we open any monad. We considered names different than [return] but everything seemed worse than just having [return] as a record field. We are clobbering the namespace of record fields but that is much more acceptable. *) type -'a return = 'a With_return.return = private { return : 'b. 'a -> 'b; } val with_return : ('a return -> 'a) -> 'a val with_return_option : ('a return -> unit) -> 'a option (** We disable [==] and [!=] and replace them with the longer and more mnemonic [phys_equal] because they too easily lead to mistakes (for example they don't even work right on Int64 or Float). One can usually use the [equal] function for a specific type, or use (=) or (<>) for built in types like char, int, float. Note that 4.02 increased cases where objects are physically equal. *) val phys_equal : 'a -> 'a -> bool val (==) : [ `Consider_using_phys_equal ] -> [ `Consider_using_phys_equal ] -> [ `Consider_using_phys_equal ] val (!=) : [ `Consider_using_phys_equal ] -> [ `Consider_using_phys_equal ] -> [ `Consider_using_phys_equal ] (** [phys_same] is like [phys_equal], but with a more general type. [phys_same] is useful when dealing with existential types, when one has a packed value and an unpacked value that one wants to check are physically equal. One can't use [phys_equal] in such a situation because the types are different. *) val phys_same : _ -> _ -> bool val force : 'a Lazy.t -> 'a (** See {! module : Staged } for documentation *) val stage : 'a -> 'a Staged.t val unstage : 'a Staged.t -> 'a (** Raised if malloc in C bindings fail (errno * size). *) exception C_malloc_exn of int * int (** {6 Deprecated operations} The following section contains definitions that hide operations from the standard library that are considered problematic or confusing, or simply redundant. *) (** {7 Overrides for Pervasives methods that need LargeFile support} *) val seek_out : [ `Deprecated_use_out_channel ] -> [ `Deprecated_use_out_channel ] -> [ `Deprecated_use_out_channel ] val pos_out : [ `Deprecated_use_out_channel ] -> [ `Deprecated_use_out_channel ] val out_channel_length : [ `Deprecated_use_out_channel ] -> [ `Deprecated_use_out_channel ] val seek_in : [ `Deprecated_use_in_channel ] -> [ `Deprecated_use_in_channel ] -> [ `Deprecated_use_in_channel ] val pos_in : [ `Deprecated_use_in_channel ] -> [ `Deprecated_use_in_channel ] val in_channel_length : [ `Deprecated_use_in_channel ] -> [ `Deprecated_use_in_channel ] val modf : [ `Deprecated_use_float_modf ] -> [ `Deprecated_use_float_modf ] val truncate : [ `Deprecated_use_float_iround_towards_zero ] -> [ `Deprecated_use_float_iround_towards_zero ] (** we have our own version of these two, the INRIA version doesn't release the runtime lock. *) val close_in : [ `Deprecated_use_in_channel ] -> [ `Deprecated_use_in_channel ] val close_out : [ `Deprecated_use_out_channel ] -> [ `Deprecated_use_out_channel ] val ( & ) : [ `Deprecated_use_two_ampersands ] -> [ `Deprecated_use_two_ampersands ] -> [ `Deprecated_use_two_ampersands ] val ( or ) : [ `Deprecated_use_pipe_pipe ] val max_int : [ `Deprecated_use_int_module ] val min_int : [ `Deprecated_use_int_module ] val ceil : [ `Deprecated_use__Float__round_up ] -> [ `Deprecated_use__Float__round_up ] val floor : [ `Deprecated_use__Float__round_down ] -> [ `Deprecated_use__Float__round_down ] val abs_float : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] val mod_float : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] val frexp : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] val ldexp : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] val float_of_int : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] val max_float : [ `Deprecated_use_float_module ] val min_float : [ `Deprecated_use_float_module ] val epsilon_float : [ `Deprecated_use_float_module ] val classify_float : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] val string_of_float : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] val float_of_string : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] val infinity : [ `Deprecated_use_float_module ] val neg_infinity : [ `Deprecated_use_float_module ] val nan : [ `Deprecated_use_float_module ] val int_of_float : [ `Deprecated_use_float_module ] -> [ `Deprecated_use_float_module ] type fpclass = [ `Deprecated_use_float_module ] core_kernel-113.00.00/src/commutative_group.ml000066400000000000000000000010141256461164500212040ustar00rootroot00000000000000(** A signature for a commutative group (in the group-theory sense). An implementation of this interface should have the following properties: 1: associativity: (a+b)+c = a+(b+c) for all elt's a,b,c 2: identity: zero+a = a+zero = a for all elt's a 3: inverses: given any elt a there exists a (unique) elt b such that a+b=b+a=zero 4: commutativity: a+b = b+a *) module type S = sig type t with sexp (* an element of the group *) val zero : t val (+) : t -> t -> t val (-) : t -> t -> t end core_kernel-113.00.00/src/comparable.ml000066400000000000000000000131451256461164500175500ustar00rootroot00000000000000open Sexplib.Conv module Sexp = Sexplib.Sexp module List = ListLabels include Comparable_intf let sprintf = Printf.sprintf module Validate (T : sig type t with compare, sexp end) : Validate with type t := T.t = struct module V = Validate let to_string t = Sexp.to_string (T.sexp_of_t t) let validate_lbound ~min t = V.of_error_opt ( match min with | Unbounded -> None | Incl b -> if T.compare t b >= 0 then None else Some (sprintf "value %s < bound %s" (to_string t) (to_string b)) | Excl b -> if T.compare t b > 0 then None else Some (sprintf "value %s <= bound %s" (to_string t) (to_string b)) ) ;; let validate_ubound ~max t = V.of_error_opt ( match max with | Unbounded -> None | Incl b -> if T.compare t b <= 0 then None else Some (sprintf "value %s > bound %s" (to_string t) (to_string b)) | Excl b -> if T.compare t b < 0 then None else Some (sprintf "value %s >= bound %s" (to_string t) (to_string b)) ) ;; let validate_bound ~min ~max = V.all [ validate_lbound ~min; validate_ubound ~max ] end module With_zero (T : sig type t with compare, sexp val zero : t include Validate with type t := t end) = struct open T let validate_positive t = validate_lbound ~min:(Excl zero) t let validate_non_negative t = validate_lbound ~min:(Incl zero) t let validate_negative t = validate_ubound ~max:(Excl zero) t let validate_non_positive t = validate_ubound ~max:(Incl zero) t let is_positive t = compare t zero > 0 let is_non_negative t = compare t zero >= 0 let is_negative t = compare t zero < 0 let is_non_positive t = compare t zero <= 0 end module Validate_with_zero (T : sig type t with compare, sexp val zero : t end) = struct module V = Validate (T) include V include With_zero (struct include T include V end) end module Map_and_set_binable (T : sig type t with bin_io, compare, sexp end) = struct module C = struct include T include Comparator.Make (T) end include C module Map = Core_map.Make_binable_using_comparator (C) module Set = Core_set.Make_binable_using_comparator (C) end module Poly (T : sig type t with sexp end) = struct module Replace_polymorphic_compare = struct type t = T.t with sexp include Polymorphic_compare let _squelch_unused_module_warning_ = () end include Polymorphic_compare let ascending = compare let descending x y = compare y x let between t ~low ~high = low <= t && t <= high module C = struct include T include Comparator.Make (Replace_polymorphic_compare) end include C module Map = Core_map.Make_using_comparator (C) module Set = Core_set.Make_using_comparator (C) include Validate (struct type nonrec t = t with compare, sexp end) end module Make_common (T : sig type t with compare, sexp end) = struct module Replace_polymorphic_compare = struct module Without_squelch = struct let compare = T.compare let (>) a b = compare a b > 0 let (<) a b = compare a b < 0 let (>=) a b = compare a b >= 0 let (<=) a b = compare a b <= 0 let (=) a b = compare a b = 0 let (<>) a b = compare a b <> 0 let equal = (=) let min t t' = if t <= t' then t else t' let max t t' = if t >= t' then t else t' end include Without_squelch let _squelch_unused_module_warning_ = () end include Replace_polymorphic_compare.Without_squelch let ascending = compare let descending t t' = compare t' t let between t ~low ~high = low <= t && t <= high include Validate (T) end module Make (T : sig type t with compare, sexp end) : S with type t := T.t = struct module C = struct include T include Comparator.Make (T) end include C include Make_common (C) module Map = Core_map.Make_using_comparator (C) module Set = Core_set.Make_using_comparator (C) end module Make_binable (T : sig type t with bin_io, compare, sexp end) = struct module C = struct include T include Comparator.Make (T) end include C include Make_common (C) module Map = Core_map.Make_binable_using_comparator (C) module Set = Core_set.Make_binable_using_comparator (C) end module Inherit (C : sig type t with compare end) (T : sig type t with sexp val component : t -> C.t end) = Make (struct type t = T.t with sexp let compare t t' = C.compare (T.component t) (T.component t') end) module Check_sexp_conversion (M : sig type t with sexp_of include S with type t := t val examples : t list end) : sig end = struct open M TEST_UNIT = (* These tests all use single element sets and maps, and so do not depend on the order in which elements appear in sexps. *) List.iter examples ~f:(fun t -> let set = Set.of_list [ t ] in let set_sexp = Sexp.List [ sexp_of_t t ] in assert (Pervasives.(=) set_sexp (<:sexp_of< Set.t >> set)); assert (Set.equal set (Set.t_of_sexp set_sexp)); let map = Map.of_alist_exn [ t, () ] in let map_sexp = Sexp.List [ Sexp.List [ sexp_of_t t; Sexp.List [] ]] in assert (Pervasives.(=) map_sexp (<:sexp_of< unit Map.t >> map)); assert (Map.equal (fun () () -> true) map (Map.t_of_sexp <:of_sexp< unit >> map_sexp))); ;; end (* compare [x] and [y] lexicographically using functions in the list [cmps] *) let lexicographic cmps x y = let rec loop = function | cmp :: cmps -> let res = cmp x y in if res = 0 then loop cmps else res | [] -> 0 in loop cmps ;; core_kernel-113.00.00/src/comparable.mli000066400000000000000000000055051256461164500177220ustar00rootroot00000000000000open Comparable_intf module type Infix = Infix module type Map_and_set_binable = Map_and_set_binable module type S = S module type S_binable = S_binable module type S_common = S_common module type Validate = Validate module type With_zero = With_zero type 'a bound = 'a Comparable_intf.bound = Incl of 'a | Excl of 'a | Unbounded (** [lexicographic cmps x y] compares [x] and [y] lexicographically using functions in the list [cmps]. *) val lexicographic : ('a -> 'a -> int) list -> 'a -> 'a -> int (** Inherit comparability from a component. *) module Inherit (C : sig type t with compare end) (T : sig type t with sexp val component : t -> C.t end) : S with type t := T.t (** Usage example: {[ module Foo = struct module T = struct type t = ... with compare, sexp end include T include Comparable.Make (T) end ]} Then include [Comparable.S] in the signature (see comparable_intf.mli for an example). To add an [Infix] submodule: {[ module C = Comparable.Make (T) include C module Infix = (C : Comparable.Infix with type t := t) ]} Common pattern: Define a module [O] with a restricted signature. It aims to be (locally) opened to bring useful operators into scope without shadowing unexpected variable names. E.g. in the [Date] module: {[ module O = struct include (C : Comparable.Infix with type t := t) let to_string t = .. end ]} Opening [Date] would shadow [now], but opening [Date.O] doesn't: {[ let now = .. in let someday = .. in Date.O.(now > someday) ]} *) module Make (T : sig type t with compare, sexp end) : S with type t := T.t module Make_binable (T : sig type t with bin_io, compare, sexp end) : S_binable with type t := T.t module Map_and_set_binable (T : sig type t with bin_io, compare, sexp end) : Map_and_set_binable with type t := T.t module Poly (T : sig type t with sexp end) : S with type t := T.t module Validate (T : sig type t with compare, sexp end) : Validate with type t := T.t module With_zero (T : sig type t with compare, sexp val zero : t include Validate with type t := t end) : With_zero with type t := T.t module Validate_with_zero (T : sig type t with compare, sexp val zero : t end) : sig include Validate with type t := T.t include With_zero with type t := T.t end (** [Check_sexp_conversion] checks that conversion of a map or set to a sexp uses the same sexp conversion as the underlying element. *) module Check_sexp_conversion (M : sig type t with sexp_of include S with type t := t val examples : t list end) : sig end core_kernel-113.00.00/src/comparable_intf.ml000066400000000000000000000050151256461164500205650ustar00rootroot00000000000000 module type Infix = Polymorphic_compare_intf.Infix module type Polymorphic_compare = Polymorphic_compare_intf.S (** Used for specifying a bound (either upper or lower) as inclusive, exclusive, or unbounded. *) type 'a bound = Incl of 'a | Excl of 'a | Unbounded module type Validate = sig type t val validate_lbound : min : t bound -> t Validate.check val validate_ubound : max : t bound -> t Validate.check val validate_bound : min : t bound -> max : t bound -> t Validate.check end module type With_zero = sig type t val validate_positive : t Validate.check val validate_non_negative : t Validate.check val validate_negative : t Validate.check val validate_non_positive : t Validate.check val is_positive : t -> bool val is_non_negative : t -> bool val is_negative : t -> bool val is_non_positive : t -> bool end module type S_common = sig include Polymorphic_compare (** [ascending] is identical to [compare]. [descending x y = ascending y x]. These are intended to be mnemonic when used like [List.sort ~cmp:ascending] and [List.sort ~cmp:descending], since they cause the list to be sorted in ascending or descending order, respectively. *) val ascending : t -> t -> int val descending : t -> t -> int val between : t -> low:t -> high:t -> bool module Replace_polymorphic_compare : sig include Polymorphic_compare with type t := t val _squelch_unused_module_warning_ : unit end include Comparator.S with type t := t include Validate with type t := t end (** Usage example: {[ module Foo : sig type t = ... include Comparable.S with type t := t end ]} Then use [Comparable.Make] in the struct (see comparable.mli for an example). *) module type S = sig include S_common module Map : Core_map.S with type Key.t = t with type Key.comparator_witness = comparator_witness module Set : Core_set.S with type Elt.t = t with type Elt.comparator_witness = comparator_witness end module type Map_and_set_binable = sig type t include Comparator.S with type t := t module Map : Core_map.S_binable with type Key.t = t with type Key.comparator_witness = comparator_witness module Set : Core_set.S_binable with type Elt.t = t with type Elt.comparator_witness = comparator_witness end module type S_binable = sig include S_common include Map_and_set_binable with type t := t with type comparator_witness := comparator_witness end core_kernel-113.00.00/src/comparator.ml000066400000000000000000000020111256461164500176000ustar00rootroot00000000000000open Sexplib type ('a, 'witness) t = { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Sexp.t } type ('a, 'b) comparator = ('a, 'b) t module type S = sig type t type comparator_witness val comparator : (t, comparator_witness) comparator end module type S1 = sig type 'a t type comparator_witness val comparator : ('a t, comparator_witness) comparator end module S_to_S1 (S : S) = struct type 'a t = S.t type comparator_witness = S.comparator_witness open S let comparator = comparator end module Make (M : sig type t with compare, sexp_of end) = struct include M type comparator_witness let comparator = M.({ compare; sexp_of_t }) end module Make1 (M : sig type 'a t val compare : 'a t -> 'a t -> int val sexp_of_t : 'a t -> Sexp.t end) = struct type comparator_witness let comparator = M.({ compare; sexp_of_t }) end module Poly = struct type 'a t = 'a include Make1 (struct type 'a t = 'a let compare = Pervasives.compare let sexp_of_t = <:sexp_of< _ >> end) end core_kernel-113.00.00/src/comparator.mli000066400000000000000000000024621256461164500177630ustar00rootroot00000000000000(** A type-indexed value that allows one to compare (and for generating error messages, serialize) values of the type in question. One of the type parameters is a phantom parameter used to distinguish comparators potentially built on different comparison functions. In particular, we want to distinguish those using polymorphic compare and those using a monomorphic compare. *) open Sexplib type ('a, 'witness) t = private { compare : 'a -> 'a -> int ; sexp_of_t : 'a -> Sexp.t } type ('a, 'b) comparator = ('a, 'b) t module type S = sig type t type comparator_witness val comparator : (t, comparator_witness) comparator end module type S1 = sig type 'a t type comparator_witness val comparator : ('a t, comparator_witness) comparator end module Poly : S1 with type 'a t = 'a module S_to_S1 (S : S) : S1 with type 'a t = S.t with type comparator_witness = S.comparator_witness (** The [Make] functors mint fresh types that are used as the phantom [comparator_witness]es. *) module Make (M : sig type t with compare, sexp_of end) : S with type t := M.t module Make1 (M : sig type 'a t val compare : 'a t -> 'a t -> int (* not the usual type for [compare] *) val sexp_of_t : _ t -> Sexp.t (* not the usual type for [sexp_of_t] *) end) : S1 with type 'a t := 'a M.t core_kernel-113.00.00/src/constrained_float.ml000066400000000000000000000005011256461164500211310ustar00rootroot00000000000000open Std_internal module type S = sig type t = private float with bin_io, sexp include Comparable_binable with type t := t include Hashable_binable with type t := t include Robustly_comparable with type t := t include Stringable with type t := t include Floatable with type t := t end core_kernel-113.00.00/src/container.ml000066400000000000000000000064401256461164500174250ustar00rootroot00000000000000open With_return include Container_intf type ('t, 'a, 'accum) fold = 't -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum type ('t, 'a) iter = 't -> f:('a -> unit) -> unit let iter ~fold t ~f = fold t ~init:() ~f:(fun () a -> f a) let count ~fold t ~f = fold t ~init:0 ~f:(fun n a -> if f a then n + 1 else n) let sum (type a) ~fold (module M : Commutative_group.S with type t = a) t ~f = fold t ~init:M.zero ~f:(fun n a -> M.(+) n (f a)) ;; let min_elt ~fold t ~cmp = fold t ~init:None ~f:(fun acc elt -> match acc with | None -> Some elt | Some min -> if cmp min elt > 0 then Some elt else acc) ;; let max_elt ~fold t ~cmp = fold t ~init:None ~f:(fun acc elt -> match acc with | None -> Some elt | Some max -> if cmp max elt < 0 then Some elt else acc) ;; let length ~fold c = fold c ~init:0 ~f:(fun acc _ -> acc + 1) let is_empty ~iter c = with_return (fun r -> iter c ~f:(fun _ -> r.return false); true) ;; let exists ~iter c ~f = with_return (fun r -> iter c ~f:(fun x -> if f x then r.return true); false) ;; let mem ~iter ?(equal = (=)) t a = exists ~iter t ~f:(equal a) let for_all ~iter c ~f = with_return (fun r -> iter c ~f:(fun x -> if not (f x) then r.return false); true) ;; let find_map ~iter t ~f = with_return (fun r -> iter t ~f:(fun x -> match f x with None -> () | Some _ as res -> r.return res); None) ;; let find ~iter c ~f = with_return (fun r -> iter c ~f:(fun x -> if f x then r.return (Some x)); None) ;; let to_list ~fold c = List.rev (fold c ~init:[] ~f:(fun acc x -> x :: acc)) let to_array ~fold c = Array.of_list (to_list ~fold c) module Make (T : Make_arg) : S1 with type 'a t := 'a T.t = struct let fold = T.fold let iter = match T.iter with | `Custom iter -> iter | `Define_using_fold -> fun t ~f -> iter ~fold t ~f ;; let length t = length ~fold t let is_empty t = is_empty ~iter t let sum m t = sum ~fold m t let count t ~f = count ~fold t ~f let exists t ~f = exists ~iter t ~f let for_all t ~f = for_all ~iter t ~f let find_map t ~f = find_map ~iter t ~f let find t ~f = find ~iter t ~f let to_list t = to_list ~fold t let to_array t = to_array ~fold t let mem ?equal t a = mem ~iter ?equal t a let min_elt t ~cmp = min_elt ~fold t ~cmp let max_elt t ~cmp = max_elt ~fold t ~cmp end open T (* The following functors exist as a consistency check among all the various [S?] interfaces. They ensure that each particular [S?] is an instance of a more generic signature. *) module Check (T : T1) (Elt : T1) (M : Generic with type 'a t := 'a T.t with type 'a elt := 'a Elt.t) = struct end module Check_S0 (M : S0) = Check (struct type 'a t = M.t end) (struct type 'a t = M.elt end) (M) module Check_S0_phantom (M : S0_phantom) = Check (struct type 'a t = 'a M.t end) (struct type 'a t = M.elt end) (M) module Check_S1 (M : S1) = Check (struct type 'a t = 'a M.t end) (struct type 'a t = 'a end) (M) type phantom module Check_S1_phantom (M : S1_phantom) = Check (struct type 'a t = ('a, phantom) M.t end) (struct type 'a t = 'a end) (M) module Check_S1_phantom_invariant (M : S1_phantom_invariant) = Check (struct type 'a t = ('a, phantom) M.t end) (struct type 'a t = 'a end) (M) core_kernel-113.00.00/src/container.mli000066400000000000000000000000411256461164500175650ustar00rootroot00000000000000include Container_intf.Container core_kernel-113.00.00/src/container_intf.ml000066400000000000000000000401151256461164500204420ustar00rootroot00000000000000(** This file has generic signatures for container data structures, with standard functions (iter, fold, exists, for_all, ...) that one would expect to find in any container. The idea is to include [Container.S0] or [Container.S1] in the signature for every container-like data structure (Array, List, String, ...) to ensure a consistent interface. *) open Perms.Export (* Signature for monomorphic container, e.g., string *) module type S0 = sig type t type elt (** Checks whether the provided element is there using the default equality test, using the provided [equal] function if it is not *) val mem : ?equal:(elt -> elt -> bool) -> t -> elt -> bool val length : t -> int val is_empty : t -> bool (** [iter] must allow exceptions raised in [f] to escape, terminating the iteration cleanly. The same holds for all functions below taking an [f]. *) val iter : t -> f:(elt -> unit) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t] *) val fold : t -> init:'accum -> f:('accum -> elt -> 'accum) -> 'accum (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : t -> f:(elt -> bool) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : t -> f:(elt -> bool) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : t -> f:(elt -> bool) -> int (** Returns the sum of [f i] for i in the container *) val sum : (module Commutative_group.S with type t = 'sum) -> t -> f:(elt -> 'sum) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : t -> f:(elt -> bool) -> elt option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : t -> f:(elt -> 'a option) -> 'a option val to_list : t -> elt list val to_array : t -> elt array (** Returns a min (resp max) element from the collection using the provided [cmp] function. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. Returns [None] iff the collection is empty. *) val min_elt : t -> cmp:(elt -> elt -> int) -> elt option val max_elt : t -> cmp:(elt -> elt -> int) -> elt option end module type S0_phantom = sig type elt type 'a t (** Checks whether the provided element is there using the default equality test, using the provided [equal] function if it is not *) val mem : ?equal:(elt -> elt -> bool) -> _ t -> elt -> bool val length : _ t -> int val is_empty : _ t -> bool val iter : _ t -> f:(elt -> unit) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t] *) val fold : _ t -> init:'accum -> f:('accum -> elt -> 'accum) -> 'accum (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : _ t -> f:(elt -> bool) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : _ t -> f:(elt -> bool) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : _ t -> f:(elt -> bool) -> int (** Returns the sum of [f i] for i in the container *) val sum : (module Commutative_group.S with type t = 'sum) -> _ t -> f:(elt -> 'sum) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : _ t -> f:(elt -> bool) -> elt option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : _ t -> f:(elt -> 'a option) -> 'a option val to_list : _ t -> elt list val to_array : _ t -> elt array (** Returns a min (resp max) element from the collection using the provided [cmp] function, or [None] if the collection is empty. In case of a tie, the first element encountered while traversing the collection is returned. *) val min_elt : _ t -> cmp:(elt -> elt -> int) -> elt option val max_elt : _ t -> cmp:(elt -> elt -> int) -> elt option end (* Signature for polymorphic container, e.g., 'a list or 'a array *) module type S1 = sig type 'a t (** Checks whether the provided element is there, using polymorphic compare if [equal] is not provided *) val mem : ?equal:('a -> 'a -> bool) -> 'a t -> 'a -> bool val length : 'a t -> int val is_empty : 'a t -> bool val iter : 'a t -> f:('a -> unit) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t] *) val fold : 'a t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : 'a t -> f:('a -> bool) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : 'a t -> f:('a -> bool) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : 'a t -> f:('a -> bool) -> int (** Returns the sum of [f i] for i in the container *) val sum : (module Commutative_group.S with type t = 'sum) -> 'a t -> f:('a -> 'sum) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : 'a t -> f:('a -> bool) -> 'a option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : 'a t -> f:('a -> 'b option) -> 'b option val to_list : 'a t -> 'a list val to_array : 'a t -> 'a array (** Returns a minimum (resp maximum) element from the collection using the provided [cmp] function, or [None] if the collection is empty. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. *) val min_elt : 'a t -> cmp:('a -> 'a -> int) -> 'a option val max_elt : 'a t -> cmp:('a -> 'a -> int) -> 'a option end module type S1_phantom_invariant = sig type ('a, 'phantom) t (** Checks whether the provided element is there, using polymorphic compare if [equal] is not provided *) val mem : ?equal:('a -> 'a -> bool) -> ('a, _) t -> 'a -> bool val length : (_, _) t -> int val is_empty : (_, _) t -> bool val iter : ('a, _) t -> f:('a -> unit) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t] *) val fold : ('a, _) t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : ('a, _) t -> f:('a -> bool) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : ('a, _) t -> f:('a -> bool) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : ('a, _) t -> f:('a -> bool) -> int (** Returns the sum of [f i] for i in the container *) val sum : (module Commutative_group.S with type t = 'sum) -> ('a, _) t -> f:('a -> 'sum) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : ('a, _) t -> f:('a -> bool) -> 'a option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : ('a, _) t -> f:('a -> 'b option) -> 'b option val to_list : ('a, _) t -> 'a list val to_array : ('a, _) t -> 'a array (** Returns a min (resp max) element from the collection using the provided [cmp] function. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. Returns [None] iff the collection is empty. *) val min_elt : ('a, _) t -> cmp:('a -> 'a -> int) -> 'a option val max_elt : ('a, _) t -> cmp:('a -> 'a -> int) -> 'a option end module type S1_phantom = sig type ('a, +'phantom) t include S1_phantom_invariant with type ('a, 'phantom) t := ('a, 'phantom) t end module type S1_permissions = sig type ('a, -'permissions) t (** Checks whether the provided element is there, using polymorphic compare if [equal] is not provided *) val mem : ?equal:('a -> 'a -> bool) -> ('a, [> read ]) t -> 'a -> bool val length : (_, [> read ]) t -> int val is_empty : (_, [> read ]) t -> bool val iter : ('a, [> read ]) t -> f:('a -> unit) -> unit (** [fold t ~init ~f] returns [f (... f (f (f init e1) e2) e3 ...) en], where [e1..en] are the elements of [t] *) val fold : ('a, [> read ]) t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum (** Returns [true] if and only if there exists an element for which the provided function evaluates to [true]. This is a short-circuiting operation. *) val exists : ('a, [> read ]) t -> f:('a -> bool) -> bool (** Returns [true] if and only if the provided function evaluates to [true] for all elements. This is a short-circuiting operation. *) val for_all : ('a, [> read ]) t -> f:('a -> bool) -> bool (** Returns the number of elements for which the provided function evaluates to true. *) val count : ('a, [> read ]) t -> f:('a -> bool) -> int (** Returns the sum of [f i] for i in the container *) val sum : (module Commutative_group.S with type t = 'sum) -> ('a, [> read ]) t -> f:('a -> 'sum) -> 'sum (** Returns as an [option] the first element for which [f] evaluates to true. *) val find : ('a, [> read ]) t -> f:('a -> bool) -> 'a option (** Returns the first evaluation of [f] that returns [Some], and returns [None] if there is no such element. *) val find_map : ('a, [> read ]) t -> f:('a -> 'b option) -> 'b option val to_list : ('a, [> read ]) t -> 'a list val to_array : ('a, [> read ]) t -> 'a array (** Returns a min (resp max) element from the collection using the provided [cmp] function. In case of a tie, the first element encountered while traversing the collection is returned. The implementation uses [fold] so it has the same complexity as [fold]. Returns [None] iff the collection is empty. *) val min_elt : ('a, [> read ]) t -> cmp:('a -> 'a -> int) -> 'a option val max_elt : ('a, [> read ]) t -> cmp:('a -> 'a -> int) -> 'a option end module type Generic = sig type 'a t type 'a elt val mem : ?equal:('a elt -> 'a elt -> bool) -> 'a t -> 'a elt -> bool val length : _ t -> int val is_empty : _ t -> bool val iter : 'a t -> f:('a elt -> unit) -> unit val fold : 'a t -> init:'accum -> f:('accum -> 'a elt -> 'accum) -> 'accum val exists : 'a t -> f:('a elt -> bool) -> bool val for_all : 'a t -> f:('a elt -> bool) -> bool val count : 'a t -> f:('a elt -> bool) -> int val sum : (module Commutative_group.S with type t = 'sum) -> 'a t -> f:('a elt -> 'sum) -> 'sum val find : 'a t -> f:('a elt -> bool) -> 'a elt option val find_map : 'a t -> f:('a elt -> 'b option) -> 'b option val to_list : 'a t -> 'a elt list val to_array : 'a t -> 'a elt array val min_elt : 'a t -> cmp:('a elt -> 'a elt -> int) -> 'a elt option val max_elt : 'a t -> cmp:('a elt -> 'a elt -> int) -> 'a elt option end module type Generic_phantom = sig type ('a, 'phantom) t type 'a elt val mem : ?equal:('a elt -> 'a elt -> bool) -> ('a, _) t -> 'a elt -> bool val length : (_, _) t -> int val is_empty : (_, _) t -> bool val iter : ('a, _) t -> f:('a elt -> unit) -> unit val fold : ('a, _) t -> init:'accum -> f:('accum -> 'a elt -> 'accum) -> 'accum val exists : ('a, _) t -> f:('a elt -> bool) -> bool val for_all : ('a, _) t -> f:('a elt -> bool) -> bool val count : ('a, _) t -> f:('a elt -> bool) -> int val sum : (module Commutative_group.S with type t = 'sum) -> ('a, _) t -> f:('a elt -> 'sum) -> 'sum val find : ('a, _) t -> f:('a elt -> bool) -> 'a elt option val find_map : ('a, _) t -> f:('a elt -> 'b option) -> 'b option val to_list : ('a, _) t -> 'a elt list val to_array : ('a, _) t -> 'a elt array val min_elt : ('a, _) t -> cmp:('a elt -> 'a elt -> int) -> 'a elt option val max_elt : ('a, _) t -> cmp:('a elt -> 'a elt -> int) -> 'a elt option end module type Make_arg = sig type 'a t val fold : 'a t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum (** The [iter] argument to [Container.Make] says how to implement the container's [iter] function. [`Define_using_fold] means to define [iter] via: {[ iter t ~f = Container.iter ~fold t ~f ]} [`Custom] overrides the default implementation, presumably with something more efficient. Several other functions returned by [Container.Make] are defined in terms of [iter], so passing in a more efficient [iter] will improve their efficiency as well. *) val iter : [ `Define_using_fold | `Custom of 'a t -> f:('a -> unit) -> unit ] end module type Container = sig module type S0 = S0 module type S0_phantom = S0_phantom module type S1 = S1 module type S1_phantom_invariant = S1_phantom_invariant module type S1_phantom = S1_phantom module type S1_permissions = S1_permissions module type Generic = Generic module type Generic_phantom = Generic_phantom (** Generic definitions of container operations in terms of [fold]. E.g.: [iter ~fold t ~f = fold t ~init:() ~f:(fun () a -> f a)]. *) type ('t, 'a, 'accum) fold = 't -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum type ('t, 'a) iter = 't -> f:('a -> unit) -> unit val iter : fold:('t, 'a, unit ) fold -> ('t, 'a) iter val count : fold:('t, 'a, int ) fold -> 't -> f:('a -> bool) -> int val min_elt : fold:('t, 'a, 'a option) fold -> 't -> cmp:('a -> 'a -> int) -> 'a option val max_elt : fold:('t, 'a, 'a option) fold -> 't -> cmp:('a -> 'a -> int) -> 'a option val length : fold:('t, _, int ) fold -> 't -> int val to_list : fold:('t, 'a, 'a list ) fold -> 't -> 'a list val to_array : fold:('t, 'a, 'a list ) fold -> 't -> 'a array val sum : fold : ('t, 'a, 'sum) fold -> (module Commutative_group.S with type t = 'sum) -> 't -> f:('a -> 'sum) -> 'sum (** Generic definitions of container operations in terms of [iter]. *) val is_empty : iter:('t, 'a) iter -> 't -> bool val exists : iter:('t, 'a) iter -> 't -> f:('a -> bool) -> bool val for_all : iter:('t, 'a) iter -> 't -> f:('a -> bool) -> bool val find : iter:('t, 'a) iter -> 't -> f:('a -> bool) -> 'a option val find_map : iter:('t, 'a) iter -> 't -> f:('a -> 'b option) -> 'b option (** The idiom for using [Container.Make] is to bind the resulting module and to explicitly import each of the functions that one wants: {[ module C = Container.Make (struct ... end) let count = C.count let exists = C.exists let find = C.find ... ]} This is preferable to: {[ include Container.Make (struct ... end) ]} because the [include] makes it too easy to shadow specialized implementations of container functions ([length] being a common one). *) module Make (T : Make_arg) : S1 with type 'a t := 'a T.t end core_kernel-113.00.00/src/container_unit_tests.ml000066400000000000000000000114721256461164500217070ustar00rootroot00000000000000open Std_internal open Container module Test_generic (Elt : sig type 'a t val of_int : int -> int t val to_int : int t -> int end) (Container : sig type 'a t with sexp include Generic with type 'a t := 'a t with type 'a elt := 'a Elt.t val of_list : 'a Elt.t list -> 'a t end) (* This signature constraint reminds us to add unit tests when functions are added to [Generic]. *) : sig type 'a t with sexp include Generic with type 'a t := 'a t end with type 'a t := 'a Container.t with type 'a elt := 'a Elt.t = struct open Container let find = find let find_map = find_map let fold = fold let is_empty = is_empty let iter = iter let length = length let mem = mem let sexp_of_t = sexp_of_t let t_of_sexp = t_of_sexp let to_array = to_array let to_list = to_list TEST_UNIT = List.iter [ 0; 1; 2; 3; 4; 8; 1024 ] ~f:(fun n -> let list = List.init n ~f:Elt.of_int in let c = Container.of_list list in let sort l = List.sort l ~cmp:compare in let sorts_are_equal l1 l2 = sort l1 = sort l2 in assert (n = Container.length c); assert ((n = 0) = Container.is_empty c); assert (sorts_are_equal list (Container.fold c ~init:[] ~f:(fun ac e -> e :: ac))); assert (sorts_are_equal list (Container.to_list c)); assert (sorts_are_equal list (Array.to_list (Container.to_array c))); assert (n > 0 = is_some (Container.find c ~f:(fun e -> Elt.to_int e = 0))); assert (n > 0 = is_some (Container.find c ~f:(fun e -> Elt.to_int e = n - 1))); assert (is_none (Container.find c ~f:(fun e -> Elt.to_int e = n))); assert (n > 0 = Container.mem c (Elt.of_int 0)); assert (n > 0 = Container.mem c (Elt.of_int (n - 1))); assert (not (Container.mem c (Elt.of_int n))); assert (n > 0 = is_some (Container.find_map c ~f:(fun e -> if Elt.to_int e = 0 then Some () else None))); assert (n > 0 = is_some (Container.find_map c ~f:(fun e -> if Elt.to_int e = n - 1 then Some () else None))); assert (is_none (Container.find_map c ~f:(fun e -> if Elt.to_int e = n then Some () else None))); let r = ref 0 in Container.iter c ~f:(fun e -> r := !r + Elt.to_int e); assert (!r = List.fold list ~init:0 ~f:(fun n e -> n + Elt.to_int e)); assert (!r = sum (module Int) c ~f:Elt.to_int); let c2 = <:of_sexp< int Container.t >> (<:sexp_of< int Container.t >> c) in assert (sorts_are_equal list (Container.to_list c2)); let compare_elt a b = Int.compare (Elt.to_int a) (Elt.to_int b) in if n = 0 then begin assert (!r = 0); assert (min_elt ~cmp:compare_elt c = None); assert (max_elt ~cmp:compare_elt c = None); end else begin assert (!r = (n * (n-1) / 2)); assert (Option.map ~f:Elt.to_int (min_elt ~cmp:compare_elt c) = Some 0); assert (Option.map ~f:Elt.to_int (max_elt ~cmp:compare_elt c) = Some (pred n)); end ); ;; let min_elt = min_elt let max_elt = max_elt let count = count let sum = sum let exists = exists let for_all = for_all TEST_UNIT = List.iter [ []; [true]; [false]; [false; false]; [true; false]; [false; true]; [true; true]; ] ~f:(fun bools -> let count_should_be = List.fold bools ~init:0 ~f:(fun n b -> if b then n + 1 else n) in let forall_should_be = List.fold bools ~init:true ~f:(fun ac b -> b && ac) in let exists_should_be = List.fold bools ~init:false ~f:(fun ac b -> b || ac) in let container = Container.of_list (List.map bools ~f:(fun b -> Elt.of_int (if b then 1 else 0))) in let is_one e = Elt.to_int e = 1 in assert (forall_should_be = Container.for_all container ~f:is_one); assert (exists_should_be = Container.exists container ~f:is_one); assert (count_should_be = Container.count container ~f:is_one); ) ;; end module Test_S1 = Test_generic (struct type 'a t = 'a let of_int = Fn.id let to_int = Fn.id end) include (Test_S1 (Array) : sig end) include (Test_S1 (Bag) : sig end) include (Test_S1 (Doubly_linked) : sig end) include (Test_S1 (Linked_stack) : sig end) include (Test_S1 (List) : sig end) include (Test_S1 (Queue) : sig end) include (Test_S1 (Core_stack) : sig end) core_kernel-113.00.00/src/core_arg.ml000066400000000000000000000002341256461164500172170ustar00rootroot00000000000000include Caml.Arg type t = key * spec * doc let sort_and_align lst = align (ListLabels.sort lst ~cmp:(fun (a,_,_) (b,_,_) -> compare a b )) ;; core_kernel-113.00.00/src/core_arg.mli000066400000000000000000000005361256461164500173750ustar00rootroot00000000000000(** INRIA's original command-line parsing library. The [Command] module is generally recommended over direct use of this library.. *) include module type of Caml.Arg type t = key * spec * doc (** Like [align], except that the specification list is also sorted by key *) val sort_and_align : (key * spec * doc) list -> (key * spec * doc) list core_kernel-113.00.00/src/core_array.ml000066400000000000000000001226711256461164500175760ustar00rootroot00000000000000open Perms.Export module Array = StdLabels.Array module Core_sequence = Sequence open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std module List = Core_list let invalid_argf = Core_printf.invalid_argf let failwiths = Error.failwiths type 'a t = 'a array with bin_io, compare, sexp, typerep module T = struct (* This module implements a new in-place, constant heap sorting algorithm to replace the one used by the standard libraries. Its only purpose is to be faster (hopefully strictly faster) than the base sort and stable_sort. At a high level the algorithm is: - pick two pivot points by: - pick 5 arbitrary elements from the array - sort them within the array - take the elements on either side of the middle element of the sort as the pivots - sort the array with: - all elements less than pivot1 to the left (range 1) - all elements >= pivot1 and <= pivot2 in the middle (range 2) - all elements > pivot2 to the right (range 3) - if pivot1 and pivot2 are equal, then the middle range is sorted, so ignore it - recurse into range 1, 2 (if pivot1 and pivot2 are unequal), and 3 - during recursion there are two inflection points: - if the size of the current range is small, use insertion sort to sort it - if the stack depth is large, sort the range with heap-sort to avoid n^2 worst-case behavior See the following for more information: - "Dual-Pivot Quicksort" by Vladimir Yaroslavskiy. Available at http://iaroslavski.narod.ru/quicksort/DualPivotQuicksort.pdf - "Quicksort is Optimal" by Sedgewick and Bentley. Slides at http://www.cs.princeton.edu/~rs/talks/QuicksortIsOptimal.pdf - http://www.sorting-algorithms.com/quick-sort-3-way *) module Sort = struct (* For the sake of speed we could use unsafe get/set throughout, but speed tests don't show a significant improvement. *) let get = Array.get let set = Array.set let swap arr i j = let tmp = get arr i in set arr i (get arr j); set arr j tmp ;; module type Sort = sig val sort : 'a t -> cmp:('a -> 'a -> int) -> left:int (* leftmost index of sub-array to sort *) -> right:int (* rightmost index of sub-array to sort *) -> unit end (* http://en.wikipedia.org/wiki/Insertion_sort *) module Insertion_sort : Sort = struct let sort arr ~cmp ~left ~right = let insert pos v = (* loop invariants: 1. the subarray arr[left .. i-1] is sorted 2. the subarray arr[i+1 .. pos] is sorted and contains only elements > v 3. arr[i] may be thought of as containing v *) let rec loop i = let i_next = i - 1 in if i_next >= left && cmp (get arr i_next) v > 0 then begin set arr i (get arr i_next); loop i_next end else i in let final_pos = loop pos in set arr final_pos v in (* loop invariant: arr is sorted from left to i-1, inclusive *) for i = left + 1 to right do insert i (get arr i) done ;; end (* http://en.wikipedia.org/wiki/Heapsort *) module Heap_sort : Sort = struct (* loop invariant: root's children are both either roots of max-heaps or > right *) let rec heapify arr ~cmp root ~left ~right = let relative_root = root - left in let left_child = (2 * relative_root) + left + 1 in let right_child = (2 * relative_root) + left + 2 in let largest = if left_child <= right && cmp (get arr left_child) (get arr root) > 0 then left_child else root in let largest = if right_child <= right && cmp (get arr right_child) (get arr largest) > 0 then right_child else largest in if largest <> root then begin swap arr root largest; heapify arr ~cmp largest ~left ~right end; ;; let build_heap arr ~cmp ~left ~right = (* Elements in the second half of the array are already heaps of size 1. We move through the first half of the array from back to front examining the element at hand, and the left and right children, fixing the heap property as we go. *) for i = (left + right) / 2 downto left do heapify arr ~cmp i ~left ~right; done; ;; let sort arr ~cmp ~left ~right = build_heap arr ~cmp ~left ~right; (* loop invariants: 1. the subarray arr[left ... i] is a max-heap H 2. the subarray arr[i+1 ... right] is sorted (call it S) 3. every element of H is less than every element of S *) for i = right downto left + 1 do swap arr left i; heapify arr ~cmp left ~left ~right:(i - 1); done; ;; end (* http://en.wikipedia.org/wiki/Introsort *) module Intro_sort : Sort = struct let five_element_sort arr ~cmp m1 m2 m3 m4 m5 = let compare_and_swap i j = if cmp (get arr i) (get arr j) > 0 then swap arr i j in (* optimal 5-element sorting network *) compare_and_swap m1 m2; (* 1--o-----o-----o--------------1 *) compare_and_swap m4 m5; (* | | | *) compare_and_swap m1 m3; (* 2--o-----|--o--|-----o--o-----2 *) compare_and_swap m2 m3; (* | | | | | *) compare_and_swap m1 m4; (* 3--------o--o--|--o--|--o-----3 *) compare_and_swap m3 m4; (* | | | *) compare_and_swap m2 m5; (* 4-----o--------o--o--|-----o--4 *) compare_and_swap m2 m3; (* | | | *) compare_and_swap m4 m5; (* 5-----o--------------o-----o--5 *) ;; TEST_MODULE = struct (* run [five_element_sort] on all permutations of an array of five elements *) let rec sprinkle x xs = (x :: xs) :: begin match xs with | [] -> [] | x' :: xs' -> List.map (sprinkle x xs') ~f:(fun sprinkled -> x' :: sprinkled) end let rec permutations = function | [] -> [[]] | x :: xs -> List.concat_map (permutations xs) ~f:(fun perms -> sprinkle x perms) let all_perms = permutations [1;2;3;4;5] TEST = List.length all_perms = 120 TEST = not (List.contains_dup ~compare:<:compare< int list >> all_perms) TEST = List.for_all all_perms ~f:(fun l -> let arr = Array.of_list l in five_element_sort arr ~cmp:<:compare< int >> 0 1 2 3 4; arr = [|1;2;3;4;5|]) end (* choose pivots for the array by sorting 5 elements and examining the center three elements. The goal is to choose two pivots that will either: - break the range up into 3 even partitions or - eliminate a commonly appearing element by sorting it into the center partition by itself To this end we look at the center 3 elements of the 5 and return pairs of equal elements or the widest range *) let choose_pivots arr ~cmp ~left ~right = let sixth = (right - left) / 6 in let m1 = left + sixth in let m2 = m1 + sixth in let m3 = m2 + sixth in let m4 = m3 + sixth in let m5 = m4 + sixth in five_element_sort arr ~cmp m1 m2 m3 m4 m5; let m2_val = get arr m2 in let m3_val = get arr m3 in let m4_val = get arr m4 in if cmp m2_val m3_val = 0 then (m2_val, m3_val, true) else if cmp m3_val m4_val = 0 then (m3_val, m4_val, true) else (m2_val, m4_val, false) ;; let dual_pivot_partition arr ~cmp ~left ~right = let pivot1, pivot2, pivots_equal = choose_pivots arr ~cmp ~left ~right in (* loop invariants: 1. left <= l < r <= right 2. l <= p <= r 3. l <= x < p implies arr[x] >= pivot1 and arr[x] <= pivot2 4. left <= x < l implies arr[x] < pivot1 5. r < x <= right implies arr[x] > pivot2 *) let rec loop l p r = let pv = get arr p in if cmp pv pivot1 < 0 then begin swap arr p l; cont (l + 1) (p + 1) r end else if cmp pv pivot2 > 0 then begin (* loop invariants: same as those of the outer loop *) let rec scan_backwards r = if r > p && cmp (get arr r) pivot2 > 0 then scan_backwards (r - 1) else r in let r = scan_backwards r in swap arr r p; cont l p (r - 1) end else cont l (p + 1) r and cont l p r = if p > r then (l, r) else loop l p r in let (l, r) = cont left left right in (l, r, pivots_equal) ;; let rec intro_sort arr ~max_depth ~cmp ~left ~right = let len = right - left + 1 in (* This takes care of some edge cases, such as left > right or very short arrays, since Insertion_sort.sort handles these cases properly. Thus we don't need to make sure that left and right are valid in recursive calls. *) if len <= 32 then begin Insertion_sort.sort arr ~cmp ~left ~right end else if max_depth < 0 then begin Heap_sort.sort arr ~cmp ~left ~right; end else begin let max_depth = max_depth - 1 in let (l, r, middle_sorted) = dual_pivot_partition arr ~cmp ~left ~right in intro_sort arr ~max_depth ~cmp ~left ~right:(l - 1); if not middle_sorted then intro_sort arr ~max_depth ~cmp ~left:l ~right:r; intro_sort arr ~max_depth ~cmp ~left:(r + 1) ~right; end ;; let log10_of_3 = log10 3. let log3 x = log10 x /. log10_of_3 let sort arr ~cmp ~left ~right = let len = right - left + 1 in let heap_sort_switch_depth = (* with perfect 3-way partitioning, this is the recursion depth *) int_of_float (log3 (float_of_int len)) in intro_sort arr ~max_depth:heap_sort_switch_depth ~cmp ~left ~right; ;; end module Test (M : Sort) = struct TEST_MODULE = struct let random_data ~length ~range = let arr = Array.create length 0 in for i = 0 to length - 1 do arr.(i) <- Random.int range; done; arr ;; let assert_sorted arr = M.sort arr ~left:0 ~right:(Array.length arr - 1) ~cmp:<:compare< int >>; let len = Array.length arr in let rec loop i prev = if i = len then true else if arr.(i) < prev then false else loop (i + 1) arr.(i) in loop 0 (-1) ;; TEST = assert_sorted (random_data ~length:0 ~range:100) TEST = assert_sorted (random_data ~length:1 ~range:100) TEST = assert_sorted (random_data ~length:100 ~range:1_000) TEST = assert_sorted (random_data ~length:1_000 ~range:1) TEST = assert_sorted (random_data ~length:1_000 ~range:10) TEST = assert_sorted (random_data ~length:1_000 ~range:1_000_000) end end module Insertion_test = Test (Insertion_sort) module Heap_test = Test (Heap_sort) module Intro_test = Test (Intro_sort) end let sort ?pos ?len arr ~cmp = let pos, len = Ordered_collection_common.get_pos_len_exn ?pos ?len ~length:(Array.length arr) in Sort.Intro_sort.sort arr ~cmp ~left:pos ~right:(pos + len - 1) (* Standard functions *) let append = Array.append let concat = Array.concat let copy = Array.copy let fill = Array.fill let fold_right t ~f ~init = Array.fold_right ~f t ~init (* permute params in signature *) let init = Array.init let iteri = Array.iteri let make_matrix = Array.make_matrix let map = Array.map let mapi = Array.mapi let of_list = Array.of_list let stable_sort t ~cmp = Array.stable_sort t ~cmp let sub = Array.sub let to_list = Array.to_list external create : int -> 'a -> 'a array = "caml_make_vect" let create ~len x = try create len x with Invalid_argument _ -> invalid_argf "Array.create ~len:%d: invalid length" len () ;; external get : 'a array -> int -> 'a = "%array_safe_get" external set : 'a array -> int -> 'a -> unit = "%array_safe_set" external unsafe_get : 'a array -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a array -> int -> 'a -> unit = "%array_unsafe_set" external length : 'a array -> int = "%array_length" let to_array t = t let is_empty t = length t = 0 let is_sorted t ~cmp = let rec loop i = if i < 1 then true else cmp t.(i - 1) t.(i) <= 0 && loop (i - 1) in loop (length t - 1) TEST = is_sorted [||] ~cmp:<:compare< int >> TEST = is_sorted [|0|] ~cmp:<:compare< int >> TEST = is_sorted [|0;1;2;2;4|] ~cmp:<:compare< int >> TEST = not (is_sorted [|0;1;2;3;2|] ~cmp:<:compare< int >>) let is_sorted_strictly t ~cmp = let rec loop i = if i < 1 then true else cmp t.(i - 1) t.(i) < 0 && loop (i - 1) in loop (length t - 1) ;; TEST_UNIT = List.iter ~f:(fun (t, expect) -> assert (expect = is_sorted_strictly (of_list t) ~cmp:<:compare< int >>)) [ [] , true; [ 1 ] , true; [ 1; 2 ] , true; [ 1; 1 ] , false; [ 2; 1 ] , false; [ 1; 2; 3 ], true; [ 1; 1; 3 ], false; [ 1; 2; 2 ], false; ] ;; let fold t ~init ~f = Array.fold_left t ~init ~f let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t ~cmp = Container.min_elt ~fold t ~cmp let max_elt t ~cmp = Container.max_elt ~fold t ~cmp let foldi t ~init ~f = let rec loop i ac = if i = length t then ac else loop (i + 1) (f i ac t.(i)) in loop 0 init ;; TEST = foldi [||] ~init:13 ~f:(fun _ _ _ -> failwith "bad") = 13 TEST = foldi [| 13 |] ~init:17 ~f:(fun i ac x -> ac + i + x) = 30 TEST = foldi [| 13; 17 |] ~init:19 ~f:(fun i ac x -> ac + i + x) = 50 let iter t ~f = Array.iter t ~f let concat_map t ~f = concat (to_list (map ~f t)) (** [normalize array index] returns a new index into the array such that if index is less than zero, the returned index will "wrap around" -- i.e. array.(normalize array (-1)) returns the last element of the array. *) let normalize t i = Ordered_collection_common.normalize ~length_fun:length t i (** [slice array start stop] returns a fresh array including elements [array.(start)] through [array.(stop-1)] with the small tweak that the start and stop positions are normalized and a stop index of 0 means the same thing a stop index of [Array.length array]. In summary, it's like the slicing in Python or Matlab. *) let slice t start stop = Ordered_collection_common.slice ~length_fun:length ~sub_fun:sub t start stop (** [nget array index] "normalizes" the index to {!Array.get} -- see normalize *) let nget t i = t.(normalize t i) (** [nset array index value] "normalizes" the index to {!Array.set} -- see normalize *) let nset t i v = t.(normalize t i) <- v let swap = Array_permute.swap;; (** reverses an array in place. *) let rev_inplace t = let i = ref 0 in let j = ref (length t - 1) in while !i < !j; do swap t !i !j; incr i; decr j; done ;; let of_list_rev l = match l with | [] -> [||] | a :: l -> let len = 1 + List.length l in let t = create ~len a in let r = ref l in (* We start at [len - 2] because we already put [a] at [t.(len - 1)]. *) for i = len - 2 downto 0 do match !r with | [] -> assert false | a :: l -> t.(i) <- a; r := l done; t ;; TEST_UNIT = for i = 0 to 5 do let l1 = List.init i ~f:Fn.id in let l2 = List.rev (to_list (of_list_rev l1)) in assert (l1 = l2); done; ;; (* [list_length] and [of_list_rev_map] are based on functions from the OCaml distribution. *) (* Cannot use List.length here because the List module depends on Array. *) let rec list_length accu = function | [] -> accu | _h::t -> list_length (succ accu) t let of_list_map xs ~f = match xs with | [] -> [||] | hd::tl -> let a = create ~len:(list_length 1 tl) (f hd) in let rec fill i = function | [] -> a | hd::tl -> unsafe_set a i (f hd); fill (i+1) tl in fill 1 tl let of_list_rev_map xs ~f = let t = of_list_map xs ~f in rev_inplace t; t (** [filter_opt array] returns a new array where [None] entries are omitted and [Some x] entries are replaced with [x]. Note that this changes the index at which elements will appear. *) let filter_opt t = let n = length t in let res_size = ref 0 in let first_some = ref None in for i = 0 to n - 1 do begin match t.(i) with | None -> () | Some _ as s -> if !res_size = 0 then first_some := s; incr res_size; end; done; match !first_some with | None -> [||] | Some el -> let result = create ~len:!res_size el in let pos = ref 0 in for i = 0 to n - 1 do begin match t.(i) with | None -> () | Some x -> result.(!pos) <- x; incr pos; end; done; result TEST = filter_opt [|Some 1; None; Some 2; None; Some 3|] = [|1; 2; 3|] TEST = filter_opt [|Some 1; None; Some 2|] = [|1; 2|] TEST = filter_opt [|Some 1|] = [|1|] TEST = filter_opt [|None|] = [||] TEST = filter_opt [||] = [||] (** [filter_map ~f array] maps [f] over [array] and filters [None] out of the results. *) let filter_map t ~f = filter_opt (map t ~f) (** Same as {!filter_map} but uses {!Array.mapi}. *) let filter_mapi t ~f = filter_opt (mapi t ~f) let iter2_exn t1 t2 ~f = if length t1 <> length t2 then invalid_arg "Array.iter2_exn"; iteri t1 ~f:(fun i x1 -> f x1 t2.(i)) let map2_exn t1 t2 ~f = let len = length t1 in if length t2 <> len then invalid_arg "Array.map2_exn"; init len ~f:(fun i -> f t1.(i) t2.(i)) let fold2_exn t1 t2 ~init ~f = if length t1 <> length t2 then invalid_arg "Array.fold2_exn"; foldi t1 ~init ~f:(fun i ac x -> f ac x t2.(i)) ;; TEST = fold2_exn [||] [||] ~init:13 ~f:(fun _ -> failwith "fail") = 13 TEST = fold2_exn [| 1 |] [| "1" |] ~init:[] ~f:(fun ac a b -> (a, b) :: ac) = [ 1, "1" ] (** [filter ~f array] removes the elements for which [f] returns false. *) let filter ~f = filter_map ~f:(fun x -> if f x then Some x else None) (** Like {!filter} except [f] also receives the index. *) let filteri ~f = filter_mapi ~f:(fun i x -> if f i x then Some x else None) let exists t ~f = let rec loop i = if i < 0 then false else if f t.(i) then true else loop (i - 1) in loop (length t - 1) let mem ?(equal = (=)) t a = exists t ~f:(equal a) let for_all t ~f = let rec loop i = if i < 0 then true else if f t.(i) then loop (i - 1) else false in loop (length t - 1) let for_all2_exn t1 t2 ~f = let len = length t1 in if length t2 <> len then invalid_arg "Array.for_all2_exn"; let rec loop i = if i < 0 then true else if f t1.(i) t2.(i) then loop (i - 1) else false in loop (len - 1) let equal t1 t2 ~equal = length t1 = length t2 && for_all2_exn t1 t2 ~f:equal TEST = equal [||] [||] ~equal:(=) TEST = equal [| 1 |] [| 1 |] ~equal:(=) TEST = equal [| 1; 2 |] [| 1; 2 |] ~equal:(=) TEST = not (equal [||] [| 1 |] ~equal:(=)) TEST = not (equal [| 1 |] [||] ~equal:(=)) TEST = not (equal [| 1 |] [| 1; 2 |] ~equal:(=)) TEST = not (equal [| 1; 2 |] [| 1; 3 |] ~equal:(=)) let replace t i ~f = t.(i) <- f t.(i) (** modifies an array in place -- [t.(i)] will be set to [f(t.(i))] *) let replace_all t ~f = for i = 0 to length t - 1 do t.(i) <- f t.(i) done let findi t ~f = let length = length t in let rec loop i = if i >= length then None else if f i t.(i) then Some (i, t.(i)) else loop (i + 1) in loop 0 ;; let findi_exn t ~f = match findi t ~f with | None -> raise Not_found | Some x -> x ;; let find_exn t ~f = match findi t ~f:(fun _i x -> f x) with | None -> raise Not_found | Some (_i, x) -> x ;; let find t ~f = Option.map (findi t ~f:(fun _i x -> f x)) ~f:(fun (_i, x) -> x) let find_map t ~f = let length = length t in let rec loop i = if i >= length then None else match f t.(i) with | None -> loop (i + 1) | Some _ as res -> res in loop 0 ;; let find_consecutive_duplicate t ~equal = let n = length t in if n <= 1 then None else begin let result = ref None in let i = ref 1 in let prev = ref t.(0) in while !i < n do let cur = t.(!i) in if equal cur !prev then (result := Some (!prev, cur); i := n) else (prev := cur; incr i) done; !result end ;; TEST_UNIT = List.iter ~f:(fun (l, expect) -> let t = of_list l in assert (Poly.equal expect (find_consecutive_duplicate t ~equal:Poly.equal))) [ [] , None ; [ 1 ] , None ; [ 1; 1 ] , Some (1, 1) ; [ 1; 2 ] , None ; [ 1; 2; 1 ] , None ; [ 1; 2; 2 ] , Some (2, 2) ; [ 1; 1; 2; 2 ], Some (1, 1) ] ;; let reduce t ~f = if length t = 0 then None else begin let r = ref t.(0) in for i = 1 to length t - 1 do r := f !r t.(i) done; Some !r end let reduce_exn t ~f = match reduce t ~f with | None -> invalid_arg "Array.reduce_exn" | Some v -> v let permute = Array_permute.permute let combine t1 t2 = if length t1 <> length t2 then failwith "Array.combine" else map2_exn t1 t2 ~f:(fun x1 x2 -> x1, x2) let split t = let n = length t in if n = 0 then [||], [||] else let x, y = t.(0) in let res1 = create ~len:n x in let res2 = create ~len:n y in for i = 1 to n - 1 do let x, y = t.(i) in res1.(i) <- x; res2.(i) <- y; done; res1, res2 let sorted_copy t ~cmp = let t1 = copy t in sort t1 ~cmp; t1 let partitioni_tf t ~f = let (trues, falses) = mapi t ~f:(fun i x -> if f i x then (Some x, None) else (None, Some x)) |! split in (filter_opt trues, filter_opt falses) let partition_tf t ~f = partitioni_tf t ~f:(fun _i x -> f x) let last t = t.(length t - 1) (* Convert to a sequence but does not attempt to protect against modification in the array. *) let to_sequence_mutable t = Sequence.unfold_step ~init:0 ~f:(fun i -> if i >= Array.length t then Sequence.Step.Done else Sequence.Step.Yield (t.(i), i+1)) let to_sequence t = to_sequence_mutable (copy t) TEST_UNIT = List.iter [ [||] ; [| 1 |] ; [| 1; 2; 3; 4; 5 |] ] ~f:(fun t -> assert (Sequence.to_array (to_sequence t) = t)) ;; module Infix = struct let ( <|> ) t (start, stop) = slice t start stop end (* We use [init 0] rather than [||] because all [||] are physically equal, and we want [empty] to create a new array. *) let empty () = init 0 ~f:(fun _ -> assert false) let cartesian_product t1 t2 = if is_empty t1 || is_empty t2 then empty () else let n1 = length t1 in let n2 = length t2 in let t = create ~len:(n1 * n2) (t1.(0), t2.(0)) in let r = ref 0 in for i1 = 0 to n1 - 1 do for i2 = 0 to n2 - 1 do t.(!r) <- (t1.(i1), t2.(i2)); incr r; done done; t ;; include Binary_searchable.Make1 (struct type nonrec 'a t = 'a t let get = get let length = length module For_test = struct let of_array a = a end end) (* [Array.truncate] is a safe wrapper for calling [Obj.truncate] on an array. [Obj.truncate] reduces the size of a block on the ocaml heap. For arrays, the block size is the array length. The precondition checked for [len] is exactly the one required by [Obj.truncate]. *) let truncate t ~len = if len <= 0 || len > length t then failwiths "Array.truncate got invalid len" len <:sexp_of< int >>; if len < length t then Obj.truncate (Obj.repr t) len; ;; TEST_UNIT = List.iter ~f:(fun (t, len) -> assert (Exn.does_raise (fun () -> truncate t ~len))) [ [| |] , -1 ; [| |] , 0 ; [| |] , 1 ; [| 1 |], -1 ; [| 1 |], 0 ; [| 1 |], 2 ] ;; TEST_UNIT = for orig_len = 1 to 5 do for new_len = 1 to orig_len do let t = init orig_len ~f:Fn.id in truncate t ~len:new_len; assert (length t = new_len); for i = 0 to new_len - 1 do assert (t.(i) = i); done; done; done; ;; module Sequence = struct let length = length let get = get let set = set end include Blit.Make1 (struct type nonrec 'a t = 'a t with sexp_of type 'a z = 'a include Sequence let create_like ~len t = if len = 0 then [||] else (assert (length t > 0); create ~len t.(0)) ;; let unsafe_blit = Array.blit let create_bool ~len = create ~len false end) ;; (* See OCaml perf notes for why these array blits are special cased -- in particular, the section entitled "Fast, Slow and Incorrect Array blits" of https://janestreet.github.io/ocaml-perf-notes.html *) module Int = struct type t_ = int array with bin_io, compare, sexp module Unsafe_blit = struct external unsafe_blit : src:t_ -> src_pos:int -> dst:t_ -> dst_pos:int -> len:int -> unit = "core_array_unsafe_int_blit" "noalloc" end include Blit.Make (struct type t = int let equal = (=) let of_bool b = if b then 1 else 0 end) (struct type t = t_ with sexp_of include Sequence let create ~len = create ~len 0 include Unsafe_blit end) ;; include Unsafe_blit end module Float = struct type t_ = float array with bin_io, compare, sexp module Unsafe_blit = struct external unsafe_blit : src:t_ -> src_pos:int -> dst:t_ -> dst_pos:int -> len:int -> unit = "core_array_unsafe_float_blit" "noalloc" end include Blit.Make (struct type t = float let equal = (=) let of_bool b = if b then 1. else 0. end) (struct type t = t_ with sexp_of include Sequence let create ~len = create ~len 0. include Unsafe_blit end) ;; include Unsafe_blit end end module type Permissioned = sig type ('a, -'perms) t include Container. S1_permissions with type ('a, 'perms) t := ('a, 'perms) t include Blit. S1_permissions with type ('a, 'perms) t := ('a, 'perms) t include Binary_searchable.S1_permissions with type ('a, 'perms) t := ('a, 'perms) t val length : (_, _) t -> int val is_empty : (_, _) t -> bool external get : ('a, [> read]) t -> int -> 'a = "%array_safe_get" external set : ('a, [> write]) t -> int -> 'a -> unit = "%array_safe_set" external unsafe_get : ('a, [> read]) t -> int -> 'a = "%array_unsafe_get" external unsafe_set : ('a, [> write]) t -> int -> 'a -> unit = "%array_unsafe_set" val create : len:int -> 'a -> ('a, [< _ perms]) t val init : int -> f:(int -> 'a) -> ('a, [< _ perms]) t val make_matrix : dimx:int -> dimy:int -> 'a -> (('a, [< _ perms]) t, [< _ perms]) t val append : ('a, [> read]) t -> ('a, [> read]) t -> ('a, [< _ perms]) t val concat : ('a, [> read]) t list -> ('a, [< _ perms]) t val copy : ('a, [> read]) t -> ('a, [< _ perms]) t val fill : ('a, [> write]) t -> pos:int -> len:int -> 'a -> unit val of_list : 'a list -> ('a, [< _ perms]) t val map : f:('a -> 'b) -> ('a, [> read]) t -> ('b, [< _ perms]) t val iteri : f:(int -> 'a -> unit) -> ('a, [> read]) t -> unit val mapi : f:(int -> 'a -> 'b) -> ('a, [> read]) t -> ('b, [< _ perms]) t val foldi : ('a, [> read]) t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b val fold_right : ('a, [> read]) t -> f:('a -> 'b -> 'b) -> init:'b -> 'b val sort : ?pos:int -> ?len:int -> ('a, [> read_write]) t -> cmp:('a -> 'a -> int) -> unit val stable_sort : ('a, [> read_write]) t -> cmp:('a -> 'a -> int) -> unit val is_sorted : ('a, [> read]) t -> cmp:('a -> 'a -> int) -> bool val is_sorted_strictly : ('a, [> read]) t -> cmp:('a -> 'a -> int) -> bool val concat_map : ('a, [> read]) t -> f:('a -> ('b, [> read]) t) -> ('b, [< _ perms]) t val partition_tf : ('a, [> read]) t -> f:('a -> bool) -> ('a, [< _ perms]) t * ('a, [< _ perms]) t val partitioni_tf : ('a, [> read]) t -> f:(int -> 'a -> bool) -> ('a, [< _ perms]) t * ('a, [< _ perms]) t val cartesian_product : ('a, [> read]) t -> ('b, [> read]) t -> ('a * 'b, [< _ perms]) t val normalize : ('a, _) t -> int -> int val slice : ('a, [> read]) t -> int -> int -> ('a, [< _ perms]) t val nget : ('a, [> read]) t -> int -> 'a val nset : ('a, [> write]) t -> int -> 'a -> unit val filter_opt : ('a option, [> read]) t -> ('a, [< _ perms]) t val filter_map : ('a, [> read]) t -> f:('a -> 'b option) -> ('b, [< _ perms]) t val filter_mapi : ('a, [> read]) t -> f:(int -> 'a -> 'b option) -> ('b, [< _ perms]) t val iter2_exn : ('a, [> read]) t -> ('b, [> read]) t -> f:('a -> 'b -> unit) -> unit val map2_exn : ('a, [> read]) t -> ('b, [> read]) t -> f:('a -> 'b -> 'c) -> ('c, [< _ perms]) t val fold2_exn : ('a, [> read]) t -> ('b, [> read]) t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c val for_all2_exn : ('a, [> read]) t -> ('b, [> read]) t -> f:('a -> 'b -> bool) -> bool val filter : f:('a -> bool) -> ('a, [> read]) t -> ('a, [< _ perms]) t val filteri : f:(int -> 'a -> bool) -> ('a, [> read]) t -> ('a, [< _ perms]) t val swap : ('a, [> read_write]) t -> int -> int -> unit val rev_inplace : ('a, [> read_write]) t -> unit val of_list_rev : 'a list -> ('a, [< _ perms]) t val of_list_map : 'a list -> f:('a -> 'b) -> ('b, [< _ perms]) t val of_list_rev_map : 'a list -> f:('a -> 'b) -> ('b, [< _ perms]) t val replace : ('a, [> read_write]) t -> int -> f:('a -> 'a) -> unit val replace_all : ('a, [> read_write]) t -> f:('a -> 'a) -> unit val find_exn : ('a, [> read]) t -> f:('a -> bool) -> 'a val findi : ('a, [> read]) t -> f:(int -> 'a -> bool) -> (int * 'a) option val findi_exn : ('a, [> read]) t -> f:(int -> 'a -> bool) -> int * 'a val find_consecutive_duplicate : ('a, [> read]) t -> equal:('a -> 'a -> bool) -> ('a * 'a) option val reduce : ('a, [> read]) t -> f:('a -> 'a -> 'a) -> 'a option val reduce_exn : ('a, [> read]) t -> f:('a -> 'a -> 'a) -> 'a val permute : ?random_state:Core_random.State.t -> ('a, [> read_write]) t -> unit val combine : ('a, [> read]) t -> ('b, [> read]) t -> ('a * 'b, [< _ perms]) t val split : ('a * 'b, [> read]) t -> ('a, [< _ perms]) t * ('b, [< _ perms]) t val sorted_copy : ('a, [> read]) t -> cmp:('a -> 'a -> int) -> ('a, [< _ perms]) t val last : ('a, [> read]) t -> 'a val empty : unit -> ('a, [< _ perms]) t val equal : ('a, [> read]) t -> ('a, [> read]) t -> equal:('a -> 'a -> bool) -> bool val truncate : (_, [> write]) t -> len:int -> unit module Infix : sig val ( <|> ) : ('a, [> read]) t -> int * int -> ('a, [< _ perms]) t end val to_sequence : ('a, [> read]) t -> 'a Sequence.t val to_sequence_mutable : ('a, [> read]) t -> 'a Sequence.t end module Permissioned : sig type ('a, -'perms) t with bin_io, compare, sexp module Int : sig type nonrec -'perms t = (int, 'perms) t with bin_io, compare, sexp include Blit.S_permissions with type 'perms t := 'perms t external unsafe_blit : src:[> read] t -> src_pos:int -> dst:[> write] t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_int_blit" "noalloc" end module Float : sig type nonrec -'perms t = (float, 'perms) t with bin_io, compare, sexp include Blit.S_permissions with type 'perms t := 'perms t external unsafe_blit : src:[> read] t -> src_pos:int -> dst:[> write] t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_float_blit" "noalloc" end val of_array_id : 'a array -> ('a, [< read_write]) t val to_array_id : ('a, [> read_write]) t -> 'a array val to_sequence_immutable : ('a, [> immutable]) t -> 'a Sequence.t include Permissioned with type ('a, 'perms) t := ('a, 'perms) t end = struct type ('a, -'perms) t = 'a array with bin_io, compare, sexp, typerep module Int = struct include T.Int type -'perms t = t_ with bin_io, compare, sexp end module Float = struct include T.Float type -'perms t = t_ with bin_io, compare, sexp end let to_array_id = Fn.id let of_array_id = Fn.id include (T : Permissioned with type ('a, 'b) t := ('a, 'b) t) let to_array = copy let to_sequence_immutable = to_sequence_mutable end module type S = sig type 'a t include Binary_searchable.S1 with type 'a t := 'a t include Container.S1 with type 'a t := 'a t external get : 'a t -> int -> 'a = "%array_safe_get" external set : 'a t -> int -> 'a -> unit = "%array_safe_set" external unsafe_get : 'a t -> int -> 'a = "%array_unsafe_get" external unsafe_set : 'a t -> int -> 'a -> unit = "%array_unsafe_set" val create : len:int -> 'a -> 'a t val init : int -> f:(int -> 'a) -> 'a t val make_matrix : dimx:int -> dimy:int -> 'a -> 'a t t val append : 'a t -> 'a t -> 'a t val concat : 'a t list -> 'a t val copy : 'a t -> 'a t val fill : 'a t -> pos:int -> len:int -> 'a -> unit include Blit.S1 with type 'a t := 'a t val of_list : 'a list -> 'a t val map : f:('a -> 'b) -> 'a t -> 'b t val iteri : f:(int -> 'a -> unit) -> 'a t -> unit val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b val fold_right : 'a t -> f:('a -> 'b -> 'b) -> init:'b -> 'b val sort : ?pos:int -> ?len:int -> 'a t -> cmp:('a -> 'a -> int) -> unit val stable_sort : 'a t -> cmp:('a -> 'a -> int) -> unit val is_sorted : 'a t -> cmp:('a -> 'a -> int) -> bool val is_sorted_strictly : 'a t -> cmp:('a -> 'a -> int) -> bool val concat_map : 'a t -> f:('a -> 'b t) -> 'b t val partition_tf : 'a t -> f:('a -> bool) -> 'a t * 'a t val partitioni_tf : 'a t -> f:(int -> 'a -> bool) -> 'a t * 'a t val cartesian_product : 'a t -> 'b t -> ('a * 'b) t val normalize : 'a t -> int -> int val slice : 'a t -> int -> int -> 'a t val nget : 'a t -> int -> 'a val nset : 'a t -> int -> 'a -> unit val filter_opt : 'a option t -> 'a t val filter_map : 'a t -> f:('a -> 'b option) -> 'b t val filter_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b t val iter2_exn : 'a t -> 'b t -> f:('a -> 'b -> unit) -> unit val map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val fold2_exn : 'a t -> 'b t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c val for_all2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool val filter : f:('a -> bool) -> 'a t -> 'a t val filteri : f:(int -> 'a -> bool) -> 'a t -> 'a t val swap : 'a t -> int -> int -> unit val rev_inplace : 'a t -> unit val of_list_rev : 'a list -> 'a t val of_list_map : 'a list -> f:('a -> 'b) -> 'b t val of_list_rev_map : 'a list -> f:('a -> 'b) -> 'b t val replace : 'a t -> int -> f:('a -> 'a) -> unit val replace_all : 'a t -> f:('a -> 'a) -> unit val find_exn : 'a t -> f:('a -> bool) -> 'a val findi : 'a t -> f:(int -> 'a -> bool) -> (int * 'a) option val findi_exn : 'a t -> f:(int -> 'a -> bool) -> int * 'a val find_consecutive_duplicate : 'a t -> equal:('a -> 'a -> bool) -> ('a * 'a) option val reduce : 'a t -> f:('a -> 'a -> 'a) -> 'a option val reduce_exn : 'a t -> f:('a -> 'a -> 'a) -> 'a val permute : ?random_state:Core_random.State.t -> 'a t -> unit val combine : 'a t -> 'b t -> ('a * 'b) t val split : ('a * 'b) t -> 'a t * 'b t val sorted_copy : 'a t -> cmp:('a -> 'a -> int) -> 'a t val last : 'a t -> 'a val empty : unit -> 'a t val equal : 'a t -> 'a t -> equal:('a -> 'a -> bool) -> bool val truncate : _ t -> len:int -> unit module Infix : sig val ( <|> ) : 'a t -> int * int -> 'a t end val to_sequence : 'a t -> 'a Core_sequence.t val to_sequence_mutable : 'a t -> 'a Core_sequence.t end include (T : S with type 'a t := 'a array) let max_length = Sys.max_array_length module Int = struct include T.Int type t = t_ with bin_io, compare, sexp end module Float = struct include T.Float type t = t_ with bin_io, compare, sexp end module Check1 (M : S) : sig type ('a, -'perm) t_ include Permissioned with type ('a, 'perm) t := ('a, 'perm) t_ end = struct include M type ('a, -'perm) t_ = 'a t end module Check2 (M : Permissioned) : sig type 'a t_ include S with type 'a t := 'a t_ end = struct include M type 'a t_ = ('a, read_write) t end BENCH_FUN "Array.get (int)" = let len = 300 in let arr = create ~len 0 in (fun () -> ignore(arr.(len-1))) BENCH_FUN "Array.set (int)" = let len = 300 in let arr = create ~len 0 in (fun () -> arr.(len-1) <- 100) BENCH_FUN "Array.get (float)" = let len = 300 in let arr = create ~len 0.0 in (fun () -> ignore(arr.(len-1))) BENCH_FUN "Array.set (float)" = let len = 300 in let arr = create ~len 0.0 in (fun () -> arr.(len-1) <- 1.0) BENCH_FUN "Array.get (tuple)" = let len = 300 in let arr = create ~len (1,2) in (fun () -> ignore(arr.(len-1))) BENCH_FUN "Array.set (tuple)" = let len = 300 in let arr = create ~len (1,2) in (fun () -> arr.(len-1) <- (3,4)) (* Allocation of arrays. Arrays longer than 255 elements are directly allocated to the major heap and are more expensive. *) BENCH_MODULE "Alloc" = struct let lengths = [0; 100; 255; 256; 1000] BENCH_INDEXED "create" len lengths = (fun () -> ignore (create ~len 0)) end (* Some benchmarks of the blit operations *) BENCH_MODULE "Blit" = struct let lengths = [0; 3; 5; 10; 100; 1000; 10_000] (* These measure the cost of using polymorphic blit. *) BENCH_MODULE "Poly" = struct BENCH_INDEXED "blit (tuple)" len lengths = let src = create ~len (10, 20) in let dst = create ~len (20, 30) in (fun () -> blit ~src ~src_pos:0 ~dst ~dst_pos:0 ~len) BENCH_INDEXED "blito (tuple)" len lengths = let src = create ~len (10, 20) in let dst = create ~len (20, 30) in (fun () -> blito ~src ~src_pos:0 ~dst ~dst_pos:0 ~src_len:len ()) (* Even though [int]s are immediate and don't require [caml_modify] calls, the runtime does not special case their behavior. *) BENCH_INDEXED "blit (int)" len lengths = let src = create ~len 0 in let dst = create ~len 0 in (fun () -> blit ~src ~src_pos:0 ~dst ~dst_pos:0 ~len) BENCH_INDEXED "blito without args (int)" len lengths = let src = create ~len 0 in let dst = create ~len 0 in (fun () -> blito ~src ~dst ()) BENCH_INDEXED "blito with args (int)" len lengths = let src = create ~len 0 in let dst = create ~len 0 in (fun () -> blito ~src ~src_pos:0 ~dst ~dst_pos:0 ~src_len:len ()) (* In the OCaml runtime, the handling of double tagged arrays (i.e. float arrays) is special cased. *) BENCH_INDEXED "blit (float)" len lengths = let src = create ~len 0.0 in let dst = create ~len 0.0 in (fun () -> blit ~src ~src_pos:0 ~dst ~dst_pos:0 ~len) BENCH_INDEXED "blito (float)" len lengths = let src = create ~len 0.0 in let dst = create ~len 0.0 in (fun () -> blito ~src ~src_pos:0 ~dst ~dst_pos:0 ~src_len:len ()) end (* This measures the cost of doing a blit that takes advantage of the fact that [int] has an immediate representation. *) BENCH_MODULE "Int" = struct BENCH_INDEXED "blit" len lengths = let src = create ~len 0 in let dst = create ~len 0 in (fun () -> Int.blit ~src ~src_pos:0 ~dst ~dst_pos:0 ~len) BENCH_INDEXED "blito" len lengths = let src = create ~len 0 in let dst = create ~len 0 in (fun () -> Int.blito ~src ~src_pos:0 ~dst ~dst_pos:0 ~src_len:len ()) end (* This measures the cost of doing a blit that takes advantage of the fact that [float] has an immediate representation in arrays. *) BENCH_MODULE "Float" = struct BENCH_INDEXED "blit" len lengths = let src = create ~len 0.0 in let dst = create ~len 0.0 in (fun () -> Float.blit ~src ~src_pos:0 ~dst ~dst_pos:0 ~len) BENCH_INDEXED "blito" len lengths = let src = create ~len 0.0 in let dst = create ~len 0.0 in (fun () -> Float.blito ~src ~src_pos:0 ~dst ~dst_pos:0 ~src_len:len ()) end end (* All of these benchmarks check to see if an array is empty. *) BENCH_MODULE "Is empty" = struct let arr1 : int t = empty () let arr2 = create ~len:5 0 BENCH "Polymorphic '='" = ([||] = [||]) BENCH "Array.equal" = equal ~equal:(=) [||] [||] BENCH "phys_equal" = [||] == [||] BENCH "Array.is_empty (empty)" = is_empty arr1 BENCH "Array.is_empty (non-empty)" = is_empty arr2 end core_kernel-113.00.00/src/core_array.mli000066400000000000000000000463601256461164500177470ustar00rootroot00000000000000open Perms.Export type 'a t = 'a array with bin_io, compare, sexp, typerep include Binary_searchable.S1 with type 'a t := 'a t (** Note: [Array.length] is not constant for a given array, as one can reduce it with [Array.truncate] *) include Container.S1 with type 'a t := 'a t (** Maximum length of a normal array. The maximum length of a float array is [max_length/2] on 32-bit machines and [max_length] on 64-bit machines. *) val max_length : int (** [Array.get a n] returns the element number [n] of array [a]. The first element has number 0. The last element has number [Array.length a - 1]. You can also write [a.(n)] instead of [Array.get a n]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [(Array.length a - 1)]. *) external get : 'a t -> int -> 'a = "%array_safe_get" (** [Array.set a n x] modifies array [a] in place, replacing element number [n] with [x]. You can also write [a.(n) <- x] instead of [Array.set a n x]. Raise [Invalid_argument "index out of bounds"] if [n] is outside the range 0 to [Array.length a - 1]. *) external set : 'a t -> int -> 'a -> unit = "%array_safe_set" (** Unsafe version of [get]. Can cause arbitrary behavior when used for an out-of-bounds array access *) external unsafe_get : 'a t -> int -> 'a = "%array_unsafe_get" (** Unsafe version of [set]. Can cause arbitrary behavior when used for an out-of-bounds array access *) external unsafe_set : 'a t -> int -> 'a -> unit = "%array_unsafe_set" (** [create ~len x] creates an array of length [len] with the value [x] populated in each element *) val create : len:int -> 'a -> 'a t (** [init n ~f] creates an array of length [n] where the [i]th element is initialized with [f i] (starting at zero) *) val init : int -> f:(int -> 'a) -> 'a t (** [Array.make_matrix dimx dimy e] returns a two-dimensional array (an array of arrays) with first dimension [dimx] and second dimension [dimy]. All the elements of this new matrix are initially physically equal to [e]. The element ([x,y]) of a matrix [m] is accessed with the notation [m.(x).(y)]. Raise [Invalid_argument] if [dimx] or [dimy] is negative or greater than [Sys.max_array_length]. If the value of [e] is a floating-point number, then the maximum size is only [Sys.max_array_length / 2]. *) val make_matrix : dimx:int -> dimy:int -> 'a -> 'a t t (** [Array.append v1 v2] returns a fresh array containing the concatenation of the arrays [v1] and [v2]. *) val append : 'a t -> 'a t -> 'a t (** Same as [Array.append], but concatenates a list of arrays. *) val concat : 'a t list -> 'a t (** [Array.copy a] returns a copy of [a], that is, a fresh array containing the same elements as [a]. *) val copy : 'a t -> 'a t (** [Array.fill a ofs len x] modifies the array [a] in place, storing [x] in elements number [ofs] to [ofs + len - 1]. Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not designate a valid subarray of [a]. *) val fill : 'a t -> pos:int -> len:int -> 'a -> unit (** [Array.blit v1 o1 v2 o2 len] copies [len] elements from array [v1], starting at element number [o1], to array [v2], starting at element number [o2]. It works correctly even if [v1] and [v2] are the same array, and the source and destination chunks overlap. Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not designate a valid subarray of [v1], or if [o2] and [len] do not designate a valid subarray of [v2]. [int_blit] and [float_blit] provide fast bound-checked blits for immediate data types. The unsafe versions do not bound-check the arguments. *) include Blit.S1 with type 'a t := 'a t module Int : sig type nonrec t = int t with bin_io, compare, sexp include Blit.S with type t := t external unsafe_blit : src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_int_blit" "noalloc" end module Float : sig type nonrec t = float t with bin_io, compare, sexp include Blit.S with type t := t external unsafe_blit : src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_float_blit" "noalloc" end (** [Array.of_list l] returns a fresh array containing the elements of [l]. *) val of_list : 'a list -> 'a t (** [Array.map ~f a] applies function [f] to all the elements of [a], and builds an array with the results returned by [f]: [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) val map : f:('a -> 'b) -> 'a t -> 'b t (** Same as {!Array.iter}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val iteri : f:(int -> 'a -> unit) -> 'a t -> unit (** Same as {!Array.map}, but the function is applied to the index of the element as first argument, and the element itself as second argument. *) val mapi : f:(int -> 'a -> 'b) -> 'a t -> 'b t val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b (** [Array.fold_right f a ~init] computes [f a.(0) (f a.(1) ( ... (f a.(n-1) init) ...))], where [n] is the length of the array [a]. *) val fold_right : 'a t -> f:('a -> 'b -> 'b) -> init:'b -> 'b (** All sort functions in this module sort in increasing order by default. *) (** [sort] uses constant heap space. [stable_sort] uses linear heap space. To sort only part of the array, specify [pos] to be the index to start sorting from and [len] indicating how many elements to sort. *) val sort : ?pos:int -> ?len:int -> 'a t -> cmp:('a -> 'a -> int) -> unit val stable_sort : 'a t -> cmp:('a -> 'a -> int) -> unit val is_sorted : 'a t -> cmp:('a -> 'a -> int) -> bool (** [is_sorted_strictly xs ~cmp] iff [is_sorted xs ~cmp] and no two consecutive elements in [xs] are equal according to [cmp] *) val is_sorted_strictly : 'a t -> cmp:('a -> 'a -> int) -> bool (** same as [List.concat_map] *) val concat_map : 'a t -> f:('a -> 'b array) -> 'b array val partition_tf : 'a t -> f:('a -> bool) -> 'a t * 'a t val partitioni_tf : 'a t -> f:(int -> 'a -> bool) -> 'a t * 'a t val cartesian_product : 'a t -> 'b t -> ('a * 'b) t (** [normalize array index] returns a new index into the array such that if index is less than zero, the returned index will "wrap around" -- i.e. array.(normalize array (-1)) returns the last element of the array. *) val normalize : 'a t -> int -> int (** [slice array start stop] returns a fresh array including elements [array.(start)] through [array.(stop-1)] with the small tweak that the start and stop positions are normalized and a stop index of 0 means the same thing a stop index of [Array.length array]. In summary, it's mostly like the slicing in Python or Matlab. One difference is that a stop value of 0 here is like not specifying a stop value in Python. *) val slice : 'a t -> int -> int -> 'a t (** Array access with [normalize]d index. *) val nget : 'a t -> int -> 'a (** Array modification with [normalize]d index. *) val nset : 'a t -> int -> 'a -> unit (** [filter_opt array] returns a new array where [None] entries are omitted and [Some x] entries are replaced with [x]. Note that this changes the index at which elements will appear. *) val filter_opt : 'a option t -> 'a t (** [filter_map ~f array] maps [f] over [array] and filters [None] out of the results. *) val filter_map : 'a t -> f:('a -> 'b option) -> 'b t (** Same as [filter_map] but uses {!Array.mapi}. *) val filter_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b t (** Functions with 2 suffix raise an exception if the lengths aren't the same. *) val iter2_exn : 'a t -> 'b t -> f:('a -> 'b -> unit) -> unit val map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val fold2_exn : 'a t -> 'b t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c (** [for_all2_exn t1 t2 ~f] fails if [length t1 <> length t2]. *) val for_all2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool (** [filter ~f array] removes the elements for which [f] returns false. *) val filter : f:('a -> bool) -> 'a t -> 'a t (** Like [filter] except [f] also receives the index. *) val filteri : f:(int -> 'a -> bool) -> 'a t -> 'a t (** [swap arr i j] swaps the value at index [i] with that at index [j]. *) val swap : 'a t -> int -> int -> unit (** [rev_inplace t] reverses [t] in place *) val rev_inplace : 'a t -> unit (** [of_list_rev l] converts from list then reverses in place *) val of_list_rev : 'a list -> 'a t (** [of_list_map l ~f] is the same as [of_list (List.map l ~f)] *) val of_list_map : 'a list -> f:('a -> 'b) -> 'b t (** [of_list_rev_map l ~f] is the same as [rev_inplace (of_list_map l ~f)] *) val of_list_rev_map : 'a list -> f:('a -> 'b) -> 'b t (** [replace t i ~f] = [t.(i) <- f (t.(i))]. *) val replace : 'a t -> int -> f:('a -> 'a) -> unit (** modifies an array in place -- [ar.(i)] will be set to [f(ar.(i))] *) val replace_all : 'a t -> f:('a -> 'a) -> unit (** [find_exn f t] returns the first [a] in [t] for which [f t.(i)] is true. It raises [Not_found] if there is no such [a]. *) val find_exn : 'a t -> f:('a -> bool) -> 'a (** [findi t f] returns the first index [i] of [t] for which [f i t.(i)] is true *) val findi : 'a t -> f:(int -> 'a -> bool) -> (int * 'a) option (** [findi_exn t f] returns the first index [i] of [t] for which [f i t.(i)] is true. It raises [Not_found] if there is no such element. *) val findi_exn : 'a t -> f:(int -> 'a -> bool) -> int * 'a (** [find_consecutive_duplicate t ~equal] returns the first pair of consecutive elements [(a1, a2)] in [t] such that [equal a1 a2]. They are returned in the same order as they appear in [t]. *) val find_consecutive_duplicate : 'a t -> equal:('a -> 'a -> bool) -> ('a * 'a) option (** [reduce f [a1; ...; an]] is [Some (f (... (f (f a1 a2) a3) ...) an)]. Returns [None] on the empty array. *) val reduce : 'a t -> f:('a -> 'a -> 'a) -> 'a option val reduce_exn : 'a t -> f:('a -> 'a -> 'a) -> 'a (** [permute ?random_state t] randomly permutes [t] in place. [permute] side affects [random_state] by repeated calls to [Random.State.int]. If [random_state] is not supplied, [permute] uses [Random.State.default]. *) val permute : ?random_state:Core_random.State.t -> 'a t -> unit (** [combine ar] combines two arrays to an array of pairs. *) val combine : 'a t -> 'b t -> ('a * 'b) t (** [split ar] splits an array of pairs into two arrays of single elements. *) val split : ('a * 'b) t -> 'a t * 'b t (** [sorted_copy ar cmp] returns a shallow copy of [ar] that is sorted. Similar to List.sort *) val sorted_copy : 'a t -> cmp:('a -> 'a -> int) -> 'a t val last : 'a t -> 'a (** [empty ()] creates an empty array *) val empty : unit -> 'a t val equal : 'a t -> 'a t -> equal:('a -> 'a -> bool) -> bool (** [truncate t ~len] drops [length t - len] elements from the end of [t], changing [t] so that [length t = len] afterwards. [truncate] raises if [len <= 0 || len > length t]. *) val truncate : _ t -> len:int -> unit module Infix : sig val ( <|> ) : 'a t -> int * int -> 'a t end (** [to_sequence t] converts [t] to a sequence. [t] is copied internally so that future modifications of [t] do not change the sequence. *) val to_sequence : 'a t -> 'a Sequence.t (** [to_sequence_mutable t] converts [t] to a sequence. [t] is shared with the sequence and modifications of [t] will result in modification of the sequence. *) val to_sequence_mutable : 'a t -> 'a Sequence.t (** The [Permissioned] module gives the ability to restrict permissions on an array, so you can give a function read-only access to an array, create an immutable array, etc. *) module Permissioned : sig (** The meaning of the ['perms] parameter is as usual (see the [Perms] module for more details) with the non-obvious difference that you don't need any permissions to extract the length of an array. This was done for simplicity because some information about the length of an array can leak out even if you only have write permissions since you can catch out-of-bounds errors. *) type ('a, -'perms) t with bin_io, compare, sexp module Int : sig type nonrec -'perms t = (int, 'perms) t with bin_io, compare, sexp include Blit.S_permissions with type 'perms t := 'perms t external unsafe_blit : src:[> read] t -> src_pos:int -> dst:[> write] t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_int_blit" "noalloc" end module Float : sig type nonrec -'perms t = (float, 'perms) t with bin_io, compare, sexp include Blit.S_permissions with type 'perms t := 'perms t external unsafe_blit : src:[> read] t -> src_pos:int -> dst:[> write] t -> dst_pos:int -> len:int -> unit = "core_array_unsafe_float_blit" "noalloc" end (** [of_array_id] and [to_array_id] return the same underlying array. On the other hand, [to_array] (inherited from [Container.S1_permissions] below) makes a copy. To create a new (possibly immutable) copy of an array [a], use [copy (of_array_id a)]. More generally, any function that takes a (possibly mutable) [t] can be called on an array by calling [of_array_id] on it first. There is a conceptual type equality between ['a Array.t] and [('a, read_write) Array.Permissioned.t]. The reason for not exposing this as an actual type equality is that we also want: {ul {- The type equality ['a Array.t = 'a array] for interoperability with code which does not use Core.} {- The type [('a, 'perms) Array.Permissioned.t] to be abstract, so that the permission phantom type will have an effect.} } Since we don't control the definition of ['a array], this would require a type [('a, 'perms) Array.Permissioned.t] which is abstract, except that [('a, read_write) Array.Permissioned.t] is concrete, which is not possible. *) val of_array_id : 'a array -> ('a, [< read_write]) t val to_array_id : ('a, [> read_write]) t -> 'a array (** [to_sequence_immutable t] converts [t] to a sequence. Unlike [to_sequence], [to_sequence_immutable] does not need to copy [t] since it is immutable. *) val to_sequence_immutable : ('a, [> immutable]) t -> 'a Sequence.t include Container. S1_permissions with type ('a, 'perms) t := ('a, 'perms) t include Blit. S1_permissions with type ('a, 'perms) t := ('a, 'perms) t include Binary_searchable.S1_permissions with type ('a, 'perms) t := ('a, 'perms) t (** These functions are in [Container.S1_permissions], but they are re-exposed here so that their types can be changed to make them more permissive (see comment above). *) val length : (_, _) t -> int val is_empty : (_, _) t -> bool (** counterparts of regular array functions above *) external get : ('a, [> read] ) t -> int -> 'a = "%array_safe_get" external set : ('a, [> write]) t -> int -> 'a -> unit = "%array_safe_set" external unsafe_get : ('a, [> read] ) t -> int -> 'a = "%array_unsafe_get" external unsafe_set : ('a, [> write]) t -> int -> 'a -> unit = "%array_unsafe_set" val create : len:int -> 'a -> ('a, [< _ perms]) t val init : int -> f:(int -> 'a) -> ('a, [< _ perms]) t val make_matrix : dimx:int -> dimy:int -> 'a -> (('a, [< _ perms]) t, [< _ perms]) t val append : ('a, [> read]) t -> ('a, [> read]) t -> ('a, [< _ perms]) t val concat : ('a, [> read]) t list -> ('a, [< _ perms]) t val copy : ('a, [> read]) t -> ('a, [< _ perms]) t val fill : ('a, [> write]) t -> pos:int -> len:int -> 'a -> unit val of_list : 'a list -> ('a, [< _ perms]) t val map : f:('a -> 'b) -> ('a, [> read]) t -> ('b, [< _ perms]) t val iteri : f:(int -> 'a -> unit) -> ('a, [> read]) t -> unit val mapi : f:(int -> 'a -> 'b) -> ('a, [> read]) t -> ('b, [< _ perms]) t val foldi : ('a, [> read]) t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b val fold_right : ('a, [> read]) t -> f:('a -> 'b -> 'b) -> init:'b -> 'b val sort : ?pos:int -> ?len:int -> ('a, [> read_write]) t -> cmp:('a -> 'a -> int) -> unit val stable_sort : ('a, [> read_write]) t -> cmp:('a -> 'a -> int) -> unit val is_sorted : ('a, [> read] ) t -> cmp:('a -> 'a -> int) -> bool val is_sorted_strictly : ('a, [> read] ) t -> cmp:('a -> 'a -> int) -> bool val concat_map : ('a, [> read]) t -> f:('a -> ('b, [> read]) t) -> ('b, [< _ perms]) t val partition_tf : ('a, [> read]) t -> f:('a -> bool) -> ('a, [< _ perms]) t * ('a, [< _ perms]) t val partitioni_tf : ('a, [> read]) t -> f:(int -> 'a -> bool) -> ('a, [< _ perms]) t * ('a, [< _ perms]) t val cartesian_product : ('a, [> read]) t -> ('b, [> read]) t -> ('a * 'b, [< _ perms]) t val normalize : (_, _) t -> int -> int val slice : ('a, [> read]) t -> int -> int -> ('a, [< _ perms]) t val nget : ('a, [> read] ) t -> int -> 'a val nset : ('a, [> write]) t -> int -> 'a -> unit val filter_opt : ('a option, [> read]) t -> ('a, [< _ perms]) t val filter_map : ('a, [> read]) t -> f:( 'a -> 'b option) -> ('b, [< _ perms]) t val filter_mapi : ('a, [> read]) t -> f:(int -> 'a -> 'b option) -> ('b, [< _ perms]) t val iter2_exn : ('a, [> read]) t -> ('b, [> read]) t -> f:('a -> 'b -> unit) -> unit val map2_exn : ('a, [> read]) t -> ('b, [> read]) t -> f:('a -> 'b -> 'c) -> ('c, [< _ perms]) t val fold2_exn : ('a, [> read]) t -> ('b, [> read]) t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c val for_all2_exn : ('a, [> read]) t -> ('b, [> read]) t -> f:('a -> 'b -> bool) -> bool val filter : f:('a -> bool) -> ('a, [> read]) t -> ('a, [< _ perms]) t val filteri : f:(int -> 'a -> bool) -> ('a, [> read]) t -> ('a, [< _ perms]) t val swap : ('a, [> read_write]) t -> int -> int -> unit val rev_inplace : ('a, [> read_write]) t -> unit val of_list_rev : 'a list -> ('a, [< _ perms]) t val of_list_map : 'a list -> f:('a -> 'b) -> ('b, [< _ perms]) t val of_list_rev_map : 'a list -> f:('a -> 'b) -> ('b, [< _ perms]) t val replace : ('a, [> read_write]) t -> int -> f:('a -> 'a) -> unit val replace_all : ('a, [> read_write]) t -> f:('a -> 'a) -> unit val find_exn : ('a, [> read]) t -> f:('a -> bool) -> 'a val findi : ('a, [> read]) t -> f:(int -> 'a -> bool) -> (int * 'a) option val findi_exn : ('a, [> read]) t -> f:(int -> 'a -> bool) -> int * 'a val find_consecutive_duplicate : ('a, [> read]) t -> equal:('a -> 'a -> bool) -> ('a * 'a) option val reduce : ('a, [> read]) t -> f:('a -> 'a -> 'a) -> 'a option val reduce_exn : ('a, [> read]) t -> f:('a -> 'a -> 'a) -> 'a val permute : ?random_state:Core_random.State.t -> ('a, [> read_write]) t -> unit val combine : ('a, [> read]) t -> ('b, [> read]) t -> ('a * 'b, [< _ perms]) t val split : ('a * 'b, [> read]) t -> ('a, [< _ perms]) t * ('b, [< _ perms]) t val sorted_copy : ('a, [> read]) t -> cmp:('a -> 'a -> int) -> ('a, [< _ perms]) t val last : ('a, [> read]) t -> 'a val empty : unit -> ('a, [< _ perms]) t val equal : ('a, [> read]) t -> ('a, [> read]) t -> equal:('a -> 'a -> bool) -> bool val truncate : (_, [> write]) t -> len:int -> unit module Infix : sig val ( <|> ) : ('a, [> read]) t -> int * int -> ('a, [< _ perms]) t end val to_sequence : ('a, [> read]) t -> 'a Sequence.t val to_sequence_mutable : ('a, [> read]) t -> 'a Sequence.t end core_kernel-113.00.00/src/core_array_stubs.c000066400000000000000000000020151256461164500206150ustar00rootroot00000000000000#include #include #include #include #include CAMLprim value core_array_unsafe_int_blit(value src, value src_pos, value dst, value dst_pos, value len) { /* On 32bit boxes ocaml values are 32bits long. On 64bit boxes OCaml values are 64bits long. The value type will change its size accordingly and hence the following macro works. */ memmove(&Field(dst, Long_val(dst_pos)), &Field(src, Long_val(src_pos)), Long_val(len) * sizeof(value)); return Val_unit; } CAMLprim value core_array_unsafe_float_blit(value src, value src_pos, value dst, value dst_pos, value len) { /* On both 32bit and 64bit boxes, floats are 64bits long and type casting the pointer to double achieves this. */ memmove((double *)dst + Long_val(dst_pos), (double *)src + Long_val(src_pos), Long_val(len) * sizeof(double)); return Val_unit; } core_kernel-113.00.00/src/core_bigstring.h000066400000000000000000000013241256461164500202560ustar00rootroot00000000000000#ifndef __CORE_BIGSTRING_H #define __CORE_BIGSTRING_H #include /* Bigarray flags for creating a [Bigstring.t] */ #define CORE_BIGSTRING_FLAGS (CAML_BA_CHAR | CAML_BA_C_LAYOUT) /* Do not call [unmap] for bigstrings with kind [CAML_BA_MAPPED_FILE] */ #define CORE_BIGSTRING_DESTROY_DO_NOT_UNMAP 1 /* Don't fail on bigstring with kind [CAML_BA_EXTERNAL] */ #define CORE_BIGSTRING_DESTROY_ALLOW_EXTERNAL 2 /* Destroy a bigstring: - free the memory with [free] if it is managed by ocaml - reset all its dimmensions to 0 - [unmap] if it is a memory-map - set its kind to [CAML_BA_EXTERNAL] */ void core_bigstring_destroy(struct caml_ba_array *b, int flags); #endif /* __CORE_BIGSTRING_H */ core_kernel-113.00.00/src/core_bin_prot.ml000066400000000000000000000005471256461164500202710ustar00rootroot00000000000000include Bin_prot module Writer = struct type 'a t = 'a Bin_prot.Type_class.writer = { size : 'a Size.sizer; write : 'a Write.writer; } let to_string t v = let len = t.size v in let buf = Bigstring.create len in let pos = t.write buf ~pos:0 v in assert (pos = Bigstring.length buf); Bigstring.to_string buf ;; end core_kernel-113.00.00/src/core_bytes.ml000066400000000000000000000001041256461164500175700ustar00rootroot00000000000000type t = bytes let create = Bytes.create let length = Bytes.length core_kernel-113.00.00/src/core_bytes.mli000066400000000000000000000002001256461164500177360ustar00rootroot00000000000000(** OCaml's built in [bytes] type, currently equal to [string]. *) type t = bytes val create : int -> t val length : t -> int core_kernel-113.00.00/src/core_char.ml000066400000000000000000000044521256461164500173710ustar00rootroot00000000000000open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std module Char = Caml.Char let failwithf = Core_printf.failwithf module T = struct type t = char with bin_io, sexp, typerep let compare = Char.compare let hash = Hashtbl.hash let to_string t = String.make 1 t let of_string s = match String.length s with | 1 -> String.get s 0 | _ -> failwithf "Char.of_string: %S" s () end include T include Identifiable.Make (struct include T let module_name = "Core.Std.Char" end) let to_int = Char.code let unsafe_of_int = Char.unsafe_chr (* We use our own range test when converting integers to chars rather than calling [Caml.Char.chr] because it's simple and it saves us a function call and the try-with (exceptions cost, especially in the world with backtraces). *) let int_is_ok i = let (<=) = Pervasives.(<=) in 0 <= i && i <= 255 let min_value = unsafe_of_int 0 let max_value = unsafe_of_int 255 let of_int i = if int_is_ok i then Some (unsafe_of_int i) else None ;; let of_int_exn i = if int_is_ok i then unsafe_of_int i else failwithf "Char.of_int_exn got integer out of range: %d" i () ;; let escaped = Char.escaped let lowercase = Char.lowercase let uppercase = Char.uppercase let is_lowercase t = 'a' <= t && t <= 'z' let is_uppercase t = 'A' <= t && t <= 'Z' let is_print t = ' ' <= t && t <= '~' let is_whitespace = function | '\t' | '\n' | '\011' (* vertical tab *) | '\012' (* form feed *) | '\r' | ' ' -> true | _ -> false ;; TEST = not (is_whitespace '\008') (* backspace *) TEST = is_whitespace '\009' (* '\t': horizontal tab *) TEST = is_whitespace '\010' (* '\n': line feed *) TEST = is_whitespace '\011' (* '\v': vertical tab *) TEST = is_whitespace '\012' (* '\f': form feed *) TEST = is_whitespace '\013' (* '\r': carriage return *) TEST = not (is_whitespace '\014') (* shift out *) TEST = is_whitespace '\032' (* space *) let is_digit t = '0' <= t && t <= '9' let is_alpha t = is_lowercase t || is_uppercase t let is_alphanum t = is_alpha t || is_digit t let get_digit_unsafe t = to_int t - to_int '0' let get_digit_exn t = if is_digit t then get_digit_unsafe t else failwithf "Char.get_digit_exn %C: not a digit" t () ;; let get_digit t = if is_digit t then Some (get_digit_unsafe t) else None core_kernel-113.00.00/src/core_char.mli000066400000000000000000000027431256461164500175430ustar00rootroot00000000000000(** Character operations. *) (** An alias for the type of characters. *) type t = char with bin_io, sexp, typerep include Identifiable.S with type t := t (** Return the ASCII code of the argument. *) val to_int : t -> int (** Return the character with the given ASCII code or [None] is the argument is outside the range 0 to 255. *) val of_int : int -> t option (** Return the character with the given ASCII code. Raise [Failure] if the argument is outside 0 to 255. *) val of_int_exn : int -> t val unsafe_of_int : int -> t (** Return a string representing the given character, with special characters escaped following the lexical conventions of Objective Caml. *) val escaped : t -> string (** Convert the given character to its equivalent lowercase character. *) val lowercase : t -> t (** Convert the given character to its equivalent uppercase character. *) val uppercase : t -> t (** '0' - '9' *) val is_digit : t -> bool (** 'a' - 'z' *) val is_lowercase : t -> bool (** 'A' - 'Z' *) val is_uppercase : t -> bool (** 'a' - 'z' or 'A' - 'Z' *) val is_alpha : t -> bool (** 'a' - 'z' or 'A' - 'Z' or '0' - '9' *) val is_alphanum : t -> bool (** ' ' - '~' *) val is_print : t -> bool (** ' ' or '\t' or '\r' or '\n' *) val is_whitespace : t -> bool (** Return [Some i] if [is_digit c] and [None] otherwise. *) val get_digit : t -> int option (** Return [i] if [is_digit c]. Raises [Failure] otherwise. *) val get_digit_exn : t -> int val min_value : t val max_value : t core_kernel-113.00.00/src/core_field.ml000066400000000000000000000000301256461164500175230ustar00rootroot00000000000000include Fieldslib.Field core_kernel-113.00.00/src/core_gc.ml000066400000000000000000000173511256461164500170470ustar00rootroot00000000000000open Sexplib.Std open Bin_prot.Std include Caml.Gc module Int = Core_int module Sexp = Sexplib.Sexp let sprintf = Printf.sprintf module Stat = struct type pretty_float = float with compare, bin_io, sexp let sexp_of_pretty_float f = Sexp.Atom (sprintf "%.2e" f) module T = struct type t = Caml.Gc.stat = { minor_words : pretty_float; promoted_words : pretty_float; major_words : pretty_float; minor_collections : int; major_collections : int; heap_words : int; heap_chunks : int; live_words : int; live_blocks : int; free_words : int; free_blocks : int; largest_free : int; fragments : int; compactions : int; top_heap_words : int; stack_size : int } with compare, bin_io, sexp, fields end include T include Comparable.Make(T) end module Control = struct (* The GC parameters are given as a control record. Note that these parameters can also be initialised by setting the OCAMLRUNPARAM environment variable. See the documentation of ocamlrun. *) module T = struct type t = Caml.Gc.control = { (* The size (in words) of the minor heap. Changing this parameter will trigger a minor collection. Default: 32k. *) mutable minor_heap_size : int; (* The minimum number of words to add to the major heap when increasing it. Default: 62k. *) mutable major_heap_increment : int; (* The major GC speed is computed from this parameter. This is the memory that will be "wasted" because the GC does not immediatly collect unreachable blocks. It is expressed as a percentage of the memory used for live data. The GC will work more (use more CPU time and collect blocks more eagerly) if space_overhead is smaller. Default: 80. *) mutable space_overhead : int; (* This value controls the GC messages on standard error output. It is a sum of some of the following flags, to print messages on the corresponding events: * 0x001 Start of major GC cycle. * 0x002 Minor collection and major GC slice. * 0x004 Growing and shrinking of the heap. * 0x008 Resizing of stacks and memory manager tables. * 0x010 Heap compaction. * 0x020 Change of GC parameters. * 0x040 Computation of major GC slice size. * 0x080 Calling of finalisation functions. * 0x100 Bytecode executable search at start-up. * 0x200 Computation of compaction triggering condition. Default: 0. *) mutable verbose : int; (* Heap compaction is triggered when the estimated amount of "wasted" memory is more than max_overhead percent of the amount of live data. If max_overhead is set to 0, heap compaction is triggered at the end of each major GC cycle (this setting is intended for testing purposes only). If max_overhead >= 1000000, compaction is never triggered. Default: 500. *) mutable max_overhead : int; (* The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime uses the operating system's stack. Default: 256k. *) mutable stack_limit : int; (** The policy used for allocating in the heap. Possible values are 0 and 1. 0 is the next-fit policy, which is quite fast but can result in fragmentation. 1 is the first-fit policy, which can be slower in some cases but can be better for programs with fragmentation problems. Default: 0. *) mutable allocation_policy : int; } with compare, bin_io, sexp, fields end include T include Comparable.Make(T) end let tune ?logger ?minor_heap_size ?major_heap_increment ?space_overhead ?verbose ?max_overhead ?stack_limit ?allocation_policy () = let module Field = Fieldslib.Field in let old_control_params = get () in let f opt to_string field = let old_value = Field.get field old_control_params in match opt with | None -> old_value | Some new_value -> Option.iter logger ~f:(fun f -> Printf.ksprintf f "Gc.Control.%s: %s -> %s" (Field.name field) (to_string old_value) (to_string new_value)); new_value in let new_control_params = Control.Fields.map ~minor_heap_size: (f minor_heap_size string_of_int) ~major_heap_increment:(f major_heap_increment string_of_int) ~space_overhead: (f space_overhead string_of_int) ~verbose: (f verbose string_of_int) ~max_overhead: (f max_overhead string_of_int) ~stack_limit: (f stack_limit string_of_int) ~allocation_policy: (f allocation_policy string_of_int) in set new_control_params ;; module Allocation_policy = struct type t = | Next_fit | First_fit let to_int = function | Next_fit -> 0 | First_fit -> 1 end let disable_compaction ?logger ~allocation_policy () = let allocation_policy = match allocation_policy with | `Don't_change -> None | `Set_to policy -> Some (Allocation_policy.to_int policy) in (* The value 1_000_000, according to http://caml.inria.fr/pub/docs/manual-ocaml-4.02/libref/Gc.html will disable compactions. *) tune ?logger ?allocation_policy ~max_overhead:1_000_000 (); ;; external minor_words : unit -> int = "core_kernel_gc_minor_words" external major_words : unit -> int = "core_kernel_gc_major_words" "noalloc" external promoted_words : unit -> int = "core_kernel_gc_promoted_words" "noalloc" external minor_collections : unit -> int = "core_kernel_gc_minor_collections" "noalloc" external major_collections : unit -> int = "core_kernel_gc_major_collections" "noalloc" external heap_words : unit -> int = "core_kernel_gc_heap_words" "noalloc" external heap_chunks : unit -> int = "core_kernel_gc_heap_chunks" "noalloc" external compactions : unit -> int = "core_kernel_gc_compactions" "noalloc" external top_heap_words : unit -> int = "core_kernel_gc_top_heap_words" "noalloc" external major_plus_minor_words : unit -> int = "core_kernel_gc_major_plus_minor_words" let zero = int_of_string "0" (* The compiler won't optimize int_of_string away so it won't perform constant folding below. *) let rec keep_alive o = if zero <> 0 then keep_alive o TEST_UNIT = let r = ref () in let weak = Weak.create 1 in Weak.set weak 0 (Some r); Gc.compact (); assert (Option.is_some (Weak.get weak 0)); keep_alive r; ;; module Expert = struct let add_finalizer x f = Caml.Gc.finalise (fun x -> Exn.handle_uncaught_and_exit (fun () -> f x)) x ;; (* [add_finalizer_exn] is the same as [add_finalizer]. However, their types in core_gc.mli are different, and the type of [add_finalizer] guarantees that it always receives a heap block, which ensures that it will not raise, while [add_finalizer_exn] accepts any type, and so may raise. *) let add_finalizer_exn = add_finalizer let finalize_release = Caml.Gc.finalise_release module Alarm = struct type t = alarm let sexp_of_t _ = "" |> <:sexp_of< string >> let create f = create_alarm (fun () -> Exn.handle_uncaught_and_exit f) let delete = delete_alarm end end (* Simple inline benchmarks for GC functions *) BENCH "minor_words" = minor_words () BENCH "major_words" = major_words () BENCH "major_plus_minor_words" = major_plus_minor_words () BENCH "promoted_words" = promoted_words () BENCH "minor_collections" = minor_collections () BENCH "major_collections" = major_collections () BENCH "heap_words" = heap_words () BENCH "heap_chunks" = heap_chunks () BENCH "compactions" = compactions () BENCH "top_heap_words" = top_heap_words () BENCH "stat" = stat () BENCH "quick_stat" = quick_stat () BENCH "counters" = counters () core_kernel-113.00.00/src/core_gc.mli000066400000000000000000000402411256461164500172120ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id: gc.mli,v 1.42 2005-10-25 18:34:07 doligez Exp $ *) (** Memory management control and statistics; finalised values. *) module Stat : sig type t = { minor_words : float; (** Number of words allocated in the minor heap since the program was started. This number is accurate in byte-code programs, but only an approximation in programs compiled to native code. *) promoted_words : float; (** Number of words allocated in the minor heap that survived a minor collection and were moved to the major heap since the program was started. *) major_words : float; (** Number of words allocated in the major heap, including the promoted words, since the program was started. *) minor_collections : int; (** Number of minor collections since the program was started. *) major_collections : int; (** Number of major collection cycles completed since the program was started. *) heap_words : int; (** Total size of the major heap, in words. *) heap_chunks : int; (** Number of contiguous pieces of memory that make up the major heap. *) live_words : int; (** Number of words of live data in the major heap, including the header words. *) live_blocks : int; (** Number of live blocks in the major heap. *) free_words : int; (** Number of words in the free list. *) free_blocks : int; (** Number of blocks in the free list. *) largest_free : int; (** Size (in words) of the largest block in the free list. *) fragments : int; (** Number of wasted words due to fragmentation. These are 1-words free blocks placed between two live blocks. They are not available for allocation. *) compactions : int; (** Number of heap compactions since the program was started. *) top_heap_words : int; (** Maximum size reached by the major heap, in words. *) stack_size : int (** Current size of the stack, in words. *) } with bin_io, sexp, fields include Comparable.S with type t := t end type stat = Stat.t (** The memory management counters are returned in a [stat] record. The total amount of memory allocated by the program since it was started is (in words) [minor_words + major_words - promoted_words]. Multiply by the word size (4 on a 32-bit machine, 8 on a 64-bit machine) to get the number of bytes. *) module Control : sig type t = { mutable minor_heap_size : int; (** The size (in words) of the minor heap. Changing this parameter will trigger a minor collection. Default: 262144 words / 1MB (32bit) / 2MB (64bit). *) mutable major_heap_increment : int; (** The minimum number of words to add to the major heap when increasing it. Default: 126976 words / 0.5MB (32bit) / 1MB (64bit). *) mutable space_overhead : int; (** The major GC speed is computed from this parameter. This is the memory that will be "wasted" because the GC does not immediatly collect unreachable blocks. It is expressed as a percentage of the memory used for live data. The GC will work more (use more CPU time and collect blocks more eagerly) if [space_overhead] is smaller. Default: 80. *) mutable verbose : int; (** This value controls the GC messages on standard error output. It is a sum of some of the following flags, to print messages on the corresponding events: - [0x001] Start of major GC cycle. - [0x002] Minor collection and major GC slice. - [0x004] Growing and shrinking of the heap. - [0x008] Resizing of stacks and memory manager tables. - [0x010] Heap compaction. - [0x020] Change of GC parameters. - [0x040] Computation of major GC slice size. - [0x080] Calling of finalisation functions. - [0x100] Bytecode executable search at start-up. - [0x200] Computation of compaction triggering condition. Default: 0. *) mutable max_overhead : int; (** Heap compaction is triggered when the estimated amount of "wasted" memory is more than [max_overhead] percent of the amount of live data. If [max_overhead] is set to 0, heap compaction is triggered at the end of each major GC cycle (this setting is intended for testing purposes only). If [max_overhead >= 1000000], compaction is never triggered. Default: 500. *) mutable stack_limit : int; (** The maximum size of the stack (in words). This is only relevant to the byte-code runtime, as the native code runtime uses the operating system's stack. Default: 1048576 words / 4MB (32bit) / 8MB (64bit). *) mutable allocation_policy : int; (** The policy used for allocating in the heap. Possible values are 0 and 1. 0 is the next-fit policy, which is quite fast but can result in fragmentation. 1 is the first-fit policy, which can be slower in some cases but can be better for programs with fragmentation problems. Default: 0. *) } with bin_io, sexp, fields include Comparable.S with type t := t end type control = Control.t (** The GC parameters are given as a [control] record. Note that these parameters can also be initialised by setting the OCAMLRUNPARAM environment variable. See the documentation of ocamlrun. *) external stat : unit -> stat = "caml_gc_stat" (** Return the current values of the memory management counters in a [stat] record. This function examines every heap block to get the statistics. *) external quick_stat : unit -> stat = "caml_gc_quick_stat" (** Same as [stat] except that [live_words], [live_blocks], [free_words], [free_blocks], [largest_free], and [fragments] are set to 0. This function is much faster than [stat] because it does not need to go through the heap. *) external counters : unit -> float * float * float = "caml_gc_counters" (** Return [(minor_words, promoted_words, major_words)]. This function is as fast at [quick_stat]. *) (** The following functions return the same as [(Gc.quick_stat ()).Stat.f], avoiding any allocation (of the [stat] record or a float). On 32-bit machines the [int] may overflow. Note that [minor_words] does not allocate, but we do not annotate it as [noalloc] because we want the compiler to save the value of the allocation pointer register (%r15 on x86-64) to the global variable [caml_young_ptr] before the C stub tries to read its value. *) external minor_words : unit -> int = "core_kernel_gc_minor_words" external major_words : unit -> int = "core_kernel_gc_major_words" "noalloc" external promoted_words : unit -> int = "core_kernel_gc_promoted_words" "noalloc" external minor_collections : unit -> int = "core_kernel_gc_minor_collections" "noalloc" external major_collections : unit -> int = "core_kernel_gc_major_collections" "noalloc" external heap_words : unit -> int = "core_kernel_gc_heap_words" "noalloc" external heap_chunks : unit -> int = "core_kernel_gc_heap_chunks" "noalloc" external compactions : unit -> int = "core_kernel_gc_compactions" "noalloc" external top_heap_words : unit -> int = "core_kernel_gc_top_heap_words" "noalloc" (** This function returns [major_words () + minor_words ()]. It exists purely for speed (one call into C rather than two). Like [major_words] and [minor_words], [major_plus_minor_words] avoids allocating a [stat] record or a float, and may overflow on 32-bit machines. This function is not marked ["noalloc"] to ensure that the allocation pointer is up-to-date when the minor-heap measurement is made. *) external major_plus_minor_words : unit -> int = "core_kernel_gc_major_plus_minor_words" external get : unit -> control = "caml_gc_get" (** Return the current values of the GC parameters in a [control] record. *) external set : control -> unit = "caml_gc_set" (** [set r] changes the GC parameters according to the [control] record [r]. The normal usage is: [Gc.set { (Gc.get()) with Gc.Control.verbose = 0x00d }] *) external minor : unit -> unit = "caml_gc_minor" (** Trigger a minor collection. *) external major_slice : int -> int = "caml_gc_major_slice" (** Do a minor collection and a slice of major collection. The argument is the size of the slice, 0 to use the automatically-computed slice size. In all cases, the result is the computed slice size. *) external major : unit -> unit = "caml_gc_major" (** Do a minor collection and finish the current major collection cycle. *) external full_major : unit -> unit = "caml_gc_full_major" (** Do a minor collection, finish the current major collection cycle, and perform a complete new cycle. This will collect all currently unreachable blocks. *) external compact : unit -> unit = "caml_gc_compaction" (** Perform a full major collection and compact the heap. Note that heap compaction is a lengthy operation. *) val print_stat : out_channel -> unit (** Print the current values of the memory management counters (in human-readable form) into the channel argument. *) val allocated_bytes : unit -> float (** Return the total number of bytes allocated since the program was started. It is returned as a [float] to avoid overflow problems with [int] on 32-bit machines. *) (* [keep_alive a] ensures that [a] is live at the point where [keep_alive a] is called. It is like [ignore a], except that the compiler won't be able to simplify it and potentially collect [a] too soon. *) val keep_alive : _ -> unit (** Adjust the specified GC parameters. *) val tune : ?logger : (string -> unit) -> ?minor_heap_size : int -> ?major_heap_increment : int -> ?space_overhead : int -> ?verbose : int -> ?max_overhead : int -> ?stack_limit : int -> ?allocation_policy : int -> unit -> unit (** The policy used for allocating in the heap. The Next_fit policy is quite fast but can result in fragmentation. The First_fit policy can be slower in some cases but can be better for programs with fragmentation problems. The default is Next_fit. *) module Allocation_policy : sig type t = | Next_fit | First_fit end val disable_compaction : ?logger:(string -> unit) (** The OCaml docs strongly suggest that the allocation policy be changed from Next Fit to First Fit if disabling compaction permanently. *) -> allocation_policy:[ `Don't_change | `Set_to of Allocation_policy.t ] -> unit -> unit (** The [Expert] module contains functions that novice users should not use, due to their complexity. In particular, finalizers are difficult to use correctly, because they can run at any time, even in the middle of other code, and because unhandled exceptions in a finalizer can be raised at any point in other code. This introduces all the semantic complexities of multithreading, which is usually a bad idea. It is much easier to use async finalizers, see {!Async_core.Async_gc.add_finalizer}, which do not involve multithreading, and runs user code as ordinary async jobs. If you do use [Core] finalizers, you should strive to make the finalization function perform a simple idempotent action, like setting a ref. The same rules as for signal handlers apply to finalizers. *) module Expert : sig (** [add_finalizer b f] ensures that [f] runs after [b] becomes unreachable. The OCaml runtime only supports finalizers on heap blocks, hence [add_finalizer] requires [b : _ Heap_block.t]. The runtime essentially maintains a set of finalizer pairs: {v 'a Heap_block.t * ('a Heap_block.t -> unit) v} Each call to [add_finalizer] adds a new pair to the set. It is allowed for many pairs to have the same heap block, the same function, or both. Each pair is a distinct element of the set. After a garbage collection determines that a heap block [b] is unreachable, it removes from the set of finalizers all finalizer pairs [(b, f)] whose block is [b], and then and runs [f b] for all such pairs. Thus, a finalizer registered with [add_finalizer] will run at most once. The GC will call the finalisation functions in the order of deallocation. When several values become unreachable at the same time (i.e. during the same GC cycle), the finalisation functions will be called in the reverse order of the corresponding calls to [add_finalizer]. If [add_finalizer] is called in the same order as the values are allocated, that means each value is finalised before the values it depends upon. Of course, this becomes false if additional dependencies are introduced by assignments. In a finalizer pair [(b, f)], it is a mistake for the closure of [f] to reference (directly or indirectly) [b] -- [f] should only access [b] via its argument. Referring to [b] in any other way will cause [b] to be kept alive forever, since [f] itself is a root of garbage collection, and can itself only be collected after the pair [(b, f)] is removed from the set of finalizers. The [f] function can use all features of OCaml, including assignments that make the value reachable again. It can also loop forever (in this case, the other finalisation functions will be called during the execution of f). It can call [add_finalizer] on [v] or other values to register other functions or even itself. All finalizers are called with [Exn.handle_uncaught_and_exit], to prevent the finalizer from raising, because raising from a finalizer could raise to any allocation or GC point in any thread, which would be impossible to reason about. [add_finalizer_exn b f] is like [add_finalizer], but will raise if [b] is not a heap block. *) val add_finalizer : 'a Heap_block.t -> ('a Heap_block.t -> unit) -> unit val add_finalizer_exn : 'a -> ('a -> unit) -> unit (** The runtime essentially maintains a bool ref: {[ val finalizer_is_running : bool ref ]} The runtime uses this bool ref to ensure that only one finalizer is running at a time, by setting it to [true] when a finalizer starts and setting it to [false] when a finalizer finishes. The runtime will not start running a finalizer if [!finalizer_is_running = true]. Calling [finalize_release] essentially does [finalizer_is_running := false], which allows another finalizer to start whether or not the current finalizer finishes. *) val finalize_release : unit -> unit (** A GC alarm calls a user function at the end of each major GC cycle. *) module Alarm : sig type t with sexp_of (** [create f] arranges for [f] to be called at the end of each major GC cycle, starting with the current cycle or the next one. [f] can be called in any thread, and so introduces all the complexity of threading. [f] is called with [Exn.handle_uncaught_and_exit], to prevent it from raising, because raising could raise to any allocation or GC point in any thread, which would be impossible to reason about. *) val create : (unit -> unit) -> t (** [delete t] will stop the calls to the function associated to [t]. Calling [delete t] again has no effect. *) val delete : t -> unit end end core_kernel-113.00.00/src/core_gc_stubs.c000066400000000000000000000040031256461164500200670ustar00rootroot00000000000000#include extern double caml_stat_minor_words; extern double caml_stat_promoted_words; extern double caml_stat_major_words; extern char *caml_young_ptr; extern char *caml_young_end; extern uintnat caml_allocated_words; extern intnat caml_stat_minor_collections; extern intnat caml_stat_major_collections; extern intnat caml_stat_heap_size; extern intnat caml_stat_top_heap_size; extern intnat caml_stat_compactions; extern intnat caml_stat_heap_chunks; static long minor_words(void) { return (long) (caml_stat_minor_words + (double) Wsize_bsize (caml_young_end - caml_young_ptr)); } CAMLprim value core_kernel_gc_minor_words(value unit __attribute__((unused))) { return Val_long(minor_words()); } static long major_words(void) { return (long) (caml_stat_major_words + (double) caml_allocated_words); } CAMLprim value core_kernel_gc_major_words(value unit __attribute__((unused))) { return Val_long(major_words()); } CAMLprim value core_kernel_gc_promoted_words(value unit __attribute__((unused))) { return Val_long((long) caml_stat_promoted_words); } CAMLprim value core_kernel_gc_minor_collections(value unit __attribute__((unused))) { return Val_long(caml_stat_minor_collections); } CAMLprim value core_kernel_gc_major_collections(value unit __attribute__((unused))) { return Val_long(caml_stat_major_collections); } CAMLprim value core_kernel_gc_heap_words(value unit __attribute__((unused))) { return Val_long(caml_stat_heap_size / sizeof (value)); } CAMLprim value core_kernel_gc_heap_chunks(value unit __attribute__((unused))) { return Val_long(caml_stat_heap_chunks); } CAMLprim value core_kernel_gc_compactions(value unit __attribute__((unused))) { return Val_long(caml_stat_compactions); } CAMLprim value core_kernel_gc_top_heap_words(value unit __attribute__((unused))) { return Val_long(caml_stat_top_heap_size / sizeof (value)); } CAMLprim value core_kernel_gc_major_plus_minor_words(value unit __attribute__((unused))) { return Val_long(minor_words() + major_words()); } core_kernel-113.00.00/src/core_gc_unit_tests.ml000066400000000000000000000050771256461164500213320ustar00rootroot00000000000000open Core_gc TEST_MODULE "gc" = struct (* The idea underlying this test is that minor_words does not allocate any memory. Hence the subsequent call to quick_stat should report exactly the same number. Also: 1) This test may fail if the float is so large that it cannot fit in a 64bit int. 2) We run this in a loop because the each call to [quick_stat] allocates minor_data and this number should be picked up by [minor_words] *) TEST_UNIT = for _i = 1 to 1000 do let mw1 = minor_words () in let st = quick_stat () in let mw2 = Float.iround_towards_zero_exn st.Stat.minor_words in assert (mw1 = mw2); done (* The point of doing a [minor] in the tests below is that [st] is still live and will be promoted during the minor GC, thereby changing both the promoted words and the major words in each iteration of the loop *) TEST_UNIT = for _i = 1 to 1000 do let mw1 = major_words () in let st = quick_stat () in minor (); let mw2 = Float.iround_towards_zero_exn st.Stat.major_words in assert (mw1 = mw2); done TEST_UNIT = for _i = 1 to 1000 do let mw1 = promoted_words () in let st = quick_stat () in minor (); let mw2 = Float.iround_towards_zero_exn st.Stat.promoted_words in assert (mw1 = mw2); done TEST_UNIT = assert (major_words () + minor_words () = major_plus_minor_words ()) let stat_eq func projection = (* In the stub the record is allocated after getting the stats, so we must ensure [func] is called first. *) let x = func () in let y = projection (quick_stat ()) in x = y ;; TEST_UNIT = for _i = 1 to 1000 do assert (stat_eq minor_collections Stat.minor_collections); minor (); assert (stat_eq minor_collections Stat.minor_collections); done TEST_UNIT = for _i = 1 to 1000 do assert (stat_eq major_collections Stat.major_collections); major (); assert (stat_eq major_collections Stat.major_collections); done TEST_UNIT = for _i = 1 to 1000 do assert (stat_eq compactions Stat.compactions); compact (); assert (stat_eq compactions Stat.compactions); done TEST_UNIT = let check () = assert (stat_eq heap_chunks Stat.heap_chunks); assert (stat_eq heap_words Stat.heap_words); assert (stat_eq top_heap_words Stat.top_heap_words); in check (); let r = ref [] in let n = heap_chunks () in while not (heap_chunks () > n) do check (); r := String.create 128 :: !r done; check () end core_kernel-113.00.00/src/core_hashtbl.ml000066400000000000000000000544171256461164500201070ustar00rootroot00000000000000open Sexplib open Sexplib.Conv open Core_hashtbl_intf open With_return module Binable = Binable0 let failwiths = Error.failwiths module Hashable = Core_hashtbl_intf.Hashable let hash_param = Hashable.hash_param let hash = Hashable.hash (* A few small things copied from other parts of core because they depend on us, so we can't use them. *) module Int = struct type t = int let max (x : t) y = if x > y then x else y let min (x : t) y = if x < y then x else y end module List = Core_list module Array = Core_array let phys_equal = (==) type ('k, 'v) t = { mutable table : ('k, 'v) Avltree.t array; mutable length : int; growth_allowed: bool; hashable: 'k Hashable.t; } type ('k, 'v) hashtbl = ('k, 'v) t type 'a key = 'a module type S = S with type ('a, 'b) hashtbl = ('a, 'b) t module type S_binable = S_binable with type ('a, 'b) hashtbl = ('a, 'b) t let sexp_of_key t = t.hashable.Hashable.sexp_of_t let compare_key t = t.hashable.Hashable.compare (** Internally use a maximum size that is a power of 2. Reverses the above to find the floor power of 2 below the system max array length *) let max_table_length = Int_pow2.floor_pow2 Sys.max_array_length ;; let create ?(growth_allowed = true) ?(size = 128) ~hashable () = let size = Int.min (Int.max 1 size) max_table_length in let size = Int_pow2.ceil_pow2 size in { table = Array.create ~len:size Avltree.empty; length = 0; growth_allowed = growth_allowed; hashable; } ;; (** Supplemental hash. This may not be necessary, it is intended as a defense against poor hash functions, for which the power of 2 sized table will be especially sensitive. With some testing we may choose to add it, but this table is designed to be robust to collisions, and in most of my testing this degrades performance. *) let _supplemental_hash h = let h = h lxor ((h lsr 20) lxor (h lsr 12)) in h lxor (h lsr 7) lxor (h lsr 4) ;; exception Hash_value_must_be_non_negative with sexp let slot t key = let hash = t.hashable.Hashable.hash key in (* this is always non-negative because we do [land] with non-negative number *) hash land ((Array.length t.table) - 1) ;; let add_worker added replace t ~key ~data = let i = slot t key in let root = t.table.(i) in (* These cases should be quite common, so we manually inline them. *) match root with | Avltree.Empty -> t.table.(i) <- Avltree.Leaf (key, data); t.length <- t.length + 1; added := true | Avltree.Leaf (k, _) -> let c = compare_key t k key in if c = 0 then begin if replace then t.table.(i) <- Avltree.Leaf (key, data); added := false end else begin added := true; t.length <- t.length + 1; t.table.(i) <- if c < 0 then Avltree.Node(root, key, data, 2, Avltree.Empty) else Avltree.Node(Avltree.Empty, key, data, 2, root) end | root -> let new_root = (* The avl tree might replace the value [replace=true] or do nothing [replace=false] to the entry, in that case the table did not get bigger, so we should not increment length, we pass in the bool ref t.added so that it can tell us whether it added or replaced. We do it this way to avoid extra allocation. Since the bool is an immediate it does not go through the write barrier. *) Avltree.add ~replace root ~compare:(compare_key t) ~added ~key ~data in if !added then t.length <- t.length + 1; (* This little optimization saves a caml_modify when the tree hasn't been rebalanced. *) if not (phys_equal new_root root) then t.table.(i) <- new_root ;; let maybe_resize_table t = let len = Array.length t.table in let should_grow = t.length > len in if should_grow && t.growth_allowed then begin let new_array_length = Int.min (len * 2) max_table_length in if new_array_length > len then begin let new_table = Array.init new_array_length ~f:(fun _ -> Avltree.empty) in let old_table = t.table in let added_or_removed = ref false in t.table <- new_table; t.length <- 0; for i = 0 to Array.length old_table - 1 do Avltree.iter old_table.(i) ~f:(fun ~key ~data -> add_worker added_or_removed true t ~key ~data) done end end ;; let set t ~key ~data = add_worker (ref false) true t ~key ~data; maybe_resize_table t ;; let replace = set let add t ~key ~data = let added_or_removed = ref false in add_worker added_or_removed false t ~key ~data; if !added_or_removed then begin maybe_resize_table t; `Ok end else `Duplicate ;; let add_or_error t ~key ~data = match add t ~key ~data with | `Ok -> Result.Ok () | `Duplicate -> let sexp_of_key = sexp_of_key t in Or_error.error "Hashtbl.add_exn got key already present" key <:sexp_of< key >> ;; let add_exn t ~key ~data = Or_error.ok_exn (add_or_error t ~key ~data) ;; let clear t = for i = 0 to Array.length t.table - 1 do t.table.(i) <- Avltree.empty; done; t.length <- 0 ;; let find_and_call t key ~if_found ~if_not_found = (* with a good hash function these first two cases will be the overwhelming majority, and Avltree.find is recursive, so it can't be inlined, so doing this avoids a function call in most cases. *) match t.table.(slot t key) with | Avltree.Empty -> if_not_found key | Avltree.Leaf (k, v) -> if compare_key t k key = 0 then if_found v else if_not_found key | tree -> Avltree.find_and_call tree ~compare:(compare_key t) key ~if_found ~if_not_found ;; let find = let if_found v = Some v in let if_not_found _ = None in fun t key -> find_and_call t key ~if_found ~if_not_found ;; let mem t key = match t.table.(slot t key) with | Avltree.Empty -> false | Avltree.Leaf (k, _) -> compare_key t k key = 0 | tree -> Avltree.mem tree ~compare:(compare_key t) key ;; let remove t key = let i = slot t key in let root = t.table.(i) in let added_or_removed = ref false in let new_root = Avltree.remove root ~removed:added_or_removed ~compare:(compare_key t) key in if not (phys_equal root new_root) then t.table.(i) <- new_root; if !added_or_removed then t.length <- t.length - 1 ;; let length t = t.length let is_empty t = length t = 0 let fold t ~init ~f = if length t = 0 then init else begin let n = Array.length t.table in let acc = ref init in for i = 0 to n - 1 do match Array.unsafe_get t.table i with | Avltree.Empty -> () | Avltree.Leaf (key, data) -> acc := f ~key ~data !acc | bucket -> acc := Avltree.fold bucket ~init:!acc ~f done; !acc end ;; let iter t ~f = if t.length = 0 then () else begin let n = Array.length t.table in for i = 0 to n - 1 do match Array.unsafe_get t.table i with | Avltree.Empty -> () | Avltree.Leaf (key, data) -> f ~key ~data | bucket -> Avltree.iter bucket ~f done end ;; let invariant t = for i = 0 to Array.length t.table - 1 do Avltree.invariant t.table.(i) ~compare:(compare_key t) done; let real_len = fold t ~init:0 ~f:(fun ~key:_ ~data:_ i -> i + 1) in assert (real_len = t.length) ;; let find_exn = let if_found v = v in let if_not_found _ = raise Not_found in fun t key -> find_and_call t key ~if_found ~if_not_found ;; (*let find_default t key ~default = match find t key with | None -> default () | Some a -> a*) let existsi t ~f = with_return (fun r -> iter t ~f:(fun ~key ~data -> if f ~key ~data then r.return true); false) ;; let exists t ~f = existsi t ~f:(fun ~key:_ ~data -> f data) ;; let for_alli t ~f = not (existsi t ~f:(fun ~key ~data -> not (f ~key ~data))) let for_all t ~f = not (existsi t ~f:(fun ~key:_ ~data -> not (f data))) let mapi t ~f = let new_t = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in iter t ~f:(fun ~key ~data -> replace new_t ~key ~data:(f ~key ~data)); new_t (* How about this? *) (* let mapi t ~f = let new_t = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in let itfun ~key ~data = replace new_t ~key ~data:(f ~key ~data) in iter t ~f:itfun; new_t *) let map t ~f = mapi t ~f:(fun ~key:_ ~data -> f data) let copy t = map t ~f:Fn.id let filter_mapi t ~f = let new_t = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in iter t ~f:(fun ~key ~data -> match f ~key ~data with | Some new_data -> replace new_t ~key ~data:new_data | None -> ()); new_t (* How about this? *) (* let filter_mapi t ~f = let new_t = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in let itfun ~key ~data = match f ~key ~data with | None -> () | Some d -> replace new_t ~key ~data:d in iter t ~f:itfun; new_t *) let filter_map t ~f = filter_mapi t ~f:(fun ~key:_ ~data -> f data) let filteri t ~f = filter_mapi t ~f:(fun ~key ~data -> if f ~key ~data then Some data else None) ;; let filter t ~f = filteri t ~f:(fun ~key:_ ~data -> f data) let partition_mapi t ~f = let t0 = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in let t1 = create ~growth_allowed:t.growth_allowed ~hashable:t.hashable ~size:t.length () in iter t ~f:(fun ~key ~data -> match f ~key ~data with | `Fst new_data -> replace t0 ~key ~data:new_data | `Snd new_data -> replace t1 ~key ~data:new_data); (t0, t1) ;; let partition_map t ~f = partition_mapi t ~f:(fun ~key:_ ~data -> f data) let partitioni_tf t ~f = partition_mapi t ~f:(fun ~key ~data -> if f ~key ~data then `Fst data else `Snd data) ;; let partition_tf t ~f = partitioni_tf t ~f:(fun ~key:_ ~data -> f data) let remove_one t key = match find t key with | None -> () | Some ([] | [_]) -> remove t key | Some (_ :: tl) -> replace t ~key ~data:tl let find_or_add t id ~default = match find t id with | Some x -> x | None -> let default = default () in replace t ~key:id ~data:default; default (* Some hashtbl implementations may be able to perform this more efficiently than two separate lookups *) let find_and_remove t id = let result = find t id in if Option.is_some result then remove t id; result let change t id f = match f (find t id) with | None -> remove t id | Some data -> replace t ~key:id ~data let incr ?(by = 1) t key = change t key (function | None -> Some by | Some i -> Some (i + by)) let add_multi t ~key ~data = match find t key with | None -> replace t ~key ~data:[data] | Some l -> replace t ~key ~data:(data :: l) let remove_multi t key = match find t key with | None -> () | Some [] | Some [_] -> remove t key | Some (_ :: tl) -> replace t ~key ~data:tl let iter_vals t ~f = iter t ~f:(fun ~key:_ ~data -> f data) let create_mapped ?growth_allowed ?size ~hashable ~get_key ~get_data rows = let size = match size with Some s -> s | None -> List.length rows in let res = create ?growth_allowed ~hashable ~size () in let dupes = ref [] in List.iter rows ~f:(fun r -> let key = get_key r in let data = get_data r in if mem res key then dupes := key :: !dupes else replace res ~key ~data); match !dupes with | [] -> `Ok res | keys -> `Duplicate_keys (List.dedup ~compare:hashable.Hashable.compare keys) ;; (*let create_mapped_exn ?growth_allowed ?size ~hashable ~get_key ~get_data rows = let size = match size with Some s -> s | None -> List.length rows in let res = create ?growth_allowed ~size ~hashable () in List.iter rows ~f:(fun r -> let key = get_key r in let data = get_data r in if mem res key then let sexp_of_key = hashable.Hashable.sexp_of_t in failwiths "Hashtbl.create_mapped_exn: duplicate key" key <:sexp_of< key >> else replace res ~key ~data); res ;;*) let create_mapped_multi ?growth_allowed ?size ~hashable ~get_key ~get_data rows = let size = match size with Some s -> s | None -> List.length rows in let res = create ?growth_allowed ~size ~hashable () in List.iter rows ~f:(fun r -> let key = get_key r in let data = get_data r in add_multi res ~key ~data); res ;; let of_alist ?growth_allowed ?size ~hashable lst = match create_mapped ?growth_allowed ?size ~hashable ~get_key:fst ~get_data:snd lst with | `Ok t -> `Ok t | `Duplicate_keys k -> `Duplicate_key (List.hd_exn k) ;; let of_alist_report_all_dups ?growth_allowed ?size ~hashable lst = create_mapped ?growth_allowed ?size ~hashable ~get_key:fst ~get_data:snd lst ;; let of_alist_or_error ?growth_allowed ?size ~hashable lst = match of_alist ?growth_allowed ?size ~hashable lst with | `Ok v -> Result.Ok v | `Duplicate_key key -> let sexp_of_key = hashable.Hashable.sexp_of_t in Or_error.error "Hashtbl.of_alist_exn: duplicate key" key sexp_of_key ;; let of_alist_exn ?growth_allowed ?size ~hashable lst = match of_alist_or_error ?growth_allowed ?size ~hashable lst with | Result.Ok v -> v | Result.Error e -> Error.raise e ;; let of_alist_multi ?growth_allowed ?size ~hashable lst = create_mapped_multi ?growth_allowed ?size ~hashable ~get_key:fst ~get_data:snd lst ;; let to_alist t = fold ~f:(fun ~key ~data list -> (key, data) :: list) ~init:[] t let sexp_of_t sexp_of_key sexp_of_data t = t |> to_alist |> List.sort ~cmp:(fun (k1, _) (k2, _) -> t.hashable.compare k1 k2) |> <:sexp_of< (key * data) list >> ;; let validate ~name f t = Validate.alist ~name f (to_alist t) let keys t = fold t ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) let data t = fold ~f:(fun ~key:_ ~data list -> data::list) ~init:[] t let add_to_groups groups ~get_key ~get_data ~combine ~rows = List.iter rows ~f:(fun row -> let key = get_key row in let data = get_data row in let data = match find groups key with | None -> data | Some old -> combine old data in replace groups ~key ~data) ;; let group ?growth_allowed ?size ~hashable ~get_key ~get_data ~combine rows = let res = create ?growth_allowed ?size ~hashable () in add_to_groups res ~get_key ~get_data ~combine ~rows; res ;; let create_with_key ?growth_allowed ?size ~hashable ~get_key rows = create_mapped ?growth_allowed ?size ~hashable ~get_key ~get_data:(fun x -> x) rows ;; let create_with_key_or_error ?growth_allowed ?size ~hashable ~get_key rows = match create_with_key ?growth_allowed ?size ~hashable ~get_key rows with | `Ok t -> Result.Ok t | `Duplicate_keys keys -> let sexp_of_key = hashable.Hashable.sexp_of_t in Or_error.error "Hashtbl.create_with_key: duplicate keys" keys <:sexp_of< key list >> ;; let create_with_key_exn ?growth_allowed ?size ~hashable ~get_key rows = Or_error.ok_exn (create_with_key_or_error ?growth_allowed ?size ~hashable ~get_key rows) ;; let merge t1 t2 ~f = if not (phys_equal t1.hashable t2.hashable) then invalid_arg "Hashtbl.merge: different 'hashable' values"; let create () = create ~growth_allowed:t1.growth_allowed ~hashable:t1.hashable ~size:t1.length () in let t = create () in let unique_keys = create () in let record_key ~key ~data:_ = replace unique_keys ~key ~data:() in iter t1 ~f:record_key; iter t2 ~f:record_key; iter unique_keys ~f:(fun ~key ~data:_ -> let arg = match find t1 key, find t2 key with | None, None -> assert false | None, Some r -> `Right r | Some l, None -> `Left l | Some l, Some r -> `Both (l, r) in match f ~key arg with | Some data -> replace t ~key ~data | None -> ()); t ;; let merge_into ~f ~src ~dst = iter src ~f:(fun ~key ~data -> match f ~key data (find dst key) with | Some data -> replace dst ~key ~data | None -> ()) let filteri_inplace t ~f = let to_remove = fold t ~init:[] ~f:(fun ~key ~data ac -> if f key data then ac else key :: ac) in List.iter to_remove ~f:(fun key -> remove t key); ;; let filter_inplace t ~f = filteri_inplace t ~f:(fun _ data -> f data) ;; let equal t t' equal = length t = length t' && with_return (fun r -> iter t ~f:(fun ~key ~data -> match find t' key with | None -> r.return false | Some data' -> if not (equal data data') then r.return false); true) ;; let similar = equal module Accessors = struct let invariant = invariant let clear = clear let copy = copy let remove = remove let remove_one = remove_one let replace = replace let set = set let add = add let add_or_error = add_or_error let add_exn = add_exn let change = change let add_multi = add_multi let remove_multi = remove_multi let mem = mem let iter = iter let exists = exists let existsi = existsi let for_all = for_all let for_alli = for_alli let fold = fold let length = length let is_empty = is_empty let map = map let mapi = mapi let filter_map = filter_map let filter_mapi = filter_mapi let filter = filter let filteri = filteri let partition_map = partition_map let partition_mapi = partition_mapi let partition_tf = partition_tf let partitioni_tf = partitioni_tf let find_or_add = find_or_add let find = find let find_exn = find_exn let find_and_call = find_and_call let find_and_remove = find_and_remove let iter_vals = iter_vals let to_alist = to_alist let validate = validate let merge = merge let merge_into = merge_into let keys = keys let data = data let filter_inplace = filter_inplace let filteri_inplace = filteri_inplace let equal = equal let similar = similar let incr = incr let sexp_of_key = sexp_of_key end module type Key = Key module type Key_binable = Key_binable module Creators (Key : sig type 'a t val hashable : 'a t Hashable.t end) : sig type ('a, 'b) t_ = ('a Key.t, 'b) t val t_of_sexp : (Sexp.t -> 'a Key.t) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b) t_ include Creators with type ('a, 'b) t := ('a, 'b) t_ with type 'a key := 'a Key.t with type ('key, 'data, 'a) create_options := ('key, 'data, 'a) create_options_without_hashable end = struct let hashable = Key.hashable type ('a, 'b) t_ = ('a Key.t, 'b) t let create ?growth_allowed ?size () = create ?growth_allowed ?size ~hashable () let of_alist ?growth_allowed ?size l = of_alist ?growth_allowed ~hashable ?size l ;; let of_alist_report_all_dups ?growth_allowed ?size l = of_alist_report_all_dups ?growth_allowed ~hashable ?size l ;; let of_alist_or_error ?growth_allowed ?size l = of_alist_or_error ?growth_allowed ~hashable ?size l ;; let of_alist_exn ?growth_allowed ?size l = of_alist_exn ?growth_allowed ~hashable ?size l ;; let t_of_sexp k_of_sexp d_of_sexp sexp = let alist = <:of_sexp< (k * d) list >> sexp in of_alist_exn alist ~size:(List.length alist) ;; let of_alist_multi ?growth_allowed ?size l = of_alist_multi ?growth_allowed ~hashable ?size l ;; let create_mapped ?growth_allowed ?size ~get_key ~get_data l = create_mapped ?growth_allowed ~hashable ?size ~get_key ~get_data l ;; let create_with_key ?growth_allowed ?size ~get_key l = create_with_key ?growth_allowed ~hashable ?size ~get_key l ;; let create_with_key_or_error ?growth_allowed ?size ~get_key l = create_with_key_or_error ?growth_allowed ~hashable ?size ~get_key l ;; let create_with_key_exn ?growth_allowed ?size ~get_key l = create_with_key_exn ?growth_allowed ~hashable ?size ~get_key l ;; let group ?growth_allowed ?size ~get_key ~get_data ~combine l = group ?growth_allowed ~hashable ?size ~get_key ~get_data ~combine l ;; end module Poly = struct type ('a, 'b) t = ('a, 'b) hashtbl type 'a key = 'a let hashable = Hashable.poly include Creators (struct type 'a t = 'a let hashable = hashable end) include Accessors let sexp_of_t = sexp_of_t include Bin_prot.Utils.Make_iterable_binable2 (struct type ('a, 'b) z = ('a, 'b) t type ('a, 'b) t = ('a, 'b) z type ('a, 'b) el = 'a * 'b with bin_io type ('a, 'b) acc = ('a, 'b) t let module_name = Some "Core_kernel.Std.Hashtbl" let length = length let iter t ~f = iter t ~f:(fun ~key ~data -> f (key, data)) let init size = create ~size () let insert t (key, data) _i = match find t key with | None -> replace t ~key ~data; t | Some _ -> failwith "Core_hashtbl.bin_read_t_: duplicate key" ;; let finish = Fn.id end) end module Make (Key : Key) = struct let hashable = { Hashable. hash = Key.hash; compare = Key.compare; sexp_of_t = Key.sexp_of_t; } ;; type key = Key.t type ('a, 'b) hashtbl = ('a, 'b) t type 'a t = (key, 'a) hashtbl type 'a key_ = key include Creators (struct type 'a t = Key.t let hashable = hashable end) include Accessors let sexp_of_t sexp_of_v t = Poly.sexp_of_t Key.sexp_of_t sexp_of_v t let t_of_sexp v_of_sexp sexp = t_of_sexp Key.t_of_sexp v_of_sexp sexp end module Make_binable (Key : Key_binable) = struct include Make (Key) include Bin_prot.Utils.Make_iterable_binable1 (struct type 'a acc = 'a t type 'a t = 'a acc type 'a el = Key.t * 'a with bin_io let module_name = Some "Core_kernel.Std.Hashtbl" let length = length let iter t ~f = iter t ~f:(fun ~key ~data -> f (key, data)) let init size = create ~size () let insert t (key, data) _i = match find t key with | None -> replace t ~key ~data; t | Some _ -> failwiths "Hashtbl.bin_read_t: duplicate key" key <:sexp_of< Key.t >> ;; let finish = Fn.id end) end TEST_UNIT = (* [sexp_of_t] output is sorted by key *) let module Table = Make (struct open Bin_prot.Std type t = int with bin_io, compare, sexp let hash (x : t) = if x >= 0 then x else ~-x end) in let t = Table.create () in for key = -10 to 10; do Table.add_exn t ~key ~data:(); done; List.iter [ <:sexp_of< unit Table.t >> ; <:sexp_of< (int, unit) t >> ] ~f:(fun sexp_of_t -> let list = t |> <:sexp_of< t >> |> <:of_sexp< (int * unit) list >> in assert (Core_list.is_sorted list ~compare:(fun (i1, _) (i2, _) -> i1 - i2))) ;; core_kernel-113.00.00/src/core_hashtbl.mli000066400000000000000000000063421256461164500202520ustar00rootroot00000000000000(** Core_hashtbl is a reimplementation of the standard MoreLabels.Hashtbl. Its worst case time complexity is O(log(N)) for lookups and additions, unlike the standard MoreLabels.Hashtbl, which is O(N) A hash table is implemented as an array of AVL trees (see [Avltree]). If [growth_allowed] (default true) is false then [size] is the final size of the array, the table can always hold more elements than [size], however they will all go into tree nodes. If it is true (default) then the array will double in size when the number of elements in the table reaches twice the size of the array. When this happens all existing elements will be reinserted, which can take a long time. If you care about latency set [size] and [growth_allowed=false] if possible. We have three kinds of hash table modules: Hashtbl Hashtbl.Poly Key.Table (a class of similar modules) There are three kinds of hash-table functions: creation from nothing (create, of_alist) sexp converters (t_of_sexp, sexp_of_t, and bin_io too) accessors and mappers (fold, mem, find, map, filter_map, ...) Here is a table showing what classes of functions are available in each kind of hash-table module: creation sexp-conv accessors Hashtbl X Hashtbl.Poly X X Key.Table X X X' The entry marked with X' is there for historical reasons, and may be eliminated at some point. The upshot is that one should use [Hashtbl] for accessors, [Hashtbl.Poly] for hash-table creation and sexp conversion using polymorphic compare/hash, and [Key.Table] for hash-table creation and sexp conversion using [Key.compare] and [Key.hash]. *) (** For many students of ocaml, using hashtables is complicated by the functors. Here are a few tips: *) (** For a list of hashtable functions see [Hashtbl_intf.S].*) (** To create a hashtable with string keys use String.Table. {[ let table = String.Table.create () ~size:4 in List.iter ~f:(fun (key, data) -> Hashtbl.set table ~key ~data) [ ("A", 1); ("B", 2); ("C", 3); ]; Hashtbl.find table "C" ]} Here 4 need only be a guess at the hashtable's future size. There are other similar pre-made hashtables, eg Int63.Table or Host_and_port.Table. *) (** To create a hashtable with a custom key type use Hashable. {[ module Key = struct module T = struct type t = String.t * Int63.t with sexp let compare = compare let hash = Hashtbl.hash end include T include Hashable.Make (T) end let table = Key.Table.create () ~size:4 in List.iter ~f:(fun (key, data) -> Hashtbl.set table ~key ~data) [ (("pi", Int63.zero), 3.14159); (("e", Int63.minus_one), 2.71828); (("Euler", Int63.one), 0.577215); ]; Hashtbl.find table ("pi", Int63.zero)]} Performance {i may} improve if you define [equal] and [hash] explicitly, eg: {[ let equal (x, y) (x', y') = String.(=) x x' && Int63.(=) y y' let hash (x, y) = String.hash x + Int63.hash y * 65599 ]} *) include Core_hashtbl_intf.Hashtbl core_kernel-113.00.00/src/core_hashtbl_intf.ml000066400000000000000000000310461256461164500211200ustar00rootroot00000000000000open Sexplib module Binable = Binable0 module type Key = sig type t with compare, sexp (** Values returned by [hash] must be non-negative. An exception will be raised in the case that [hash] returns a negative value. *) val hash : t -> int end module type Key_binable = sig type t with bin_io include Key with type t := t end module Hashable = struct type 'a t = { hash : 'a -> int; compare : 'a -> 'a -> int; sexp_of_t : 'a -> Sexp.t; } let hash_param = Caml.Hashtbl.hash_param let hash = Caml.Hashtbl.hash let poly = { hash; compare; sexp_of_t = (fun _ -> Sexp.Atom "_"); } let of_key (type a) k = let module Key = (val k : Key with type t = a) in { hash = Key.hash; compare = Key.compare; sexp_of_t = Key.sexp_of_t; } ;; end module type Hashable = sig type 'a t = 'a Hashable.t = { hash : 'a -> int; compare : 'a -> 'a -> int; sexp_of_t : 'a -> Sexp.t; } val poly : 'a t val of_key : (module Key with type t = 'a) -> 'a t val hash_param : int -> int -> 'a -> int val hash : 'a -> int end type ('a,'z) no_map_options = 'z module type Accessors = sig type ('a, 'b) t type 'a key type ('a,'z) map_options val sexp_of_key : ('a, _) t -> 'a key -> Sexp.t val clear : (_, _) t -> unit val copy : ('a, 'b) t -> ('a, 'b) t val invariant : (_, _) t -> unit val fold : ('a, 'b) t -> init:'c -> f:(key:'a key -> data:'b -> 'c -> 'c) -> 'c val iter : ('a, 'b) t -> f:(key:'a key -> data:'b -> unit) -> unit val existsi : ('a, 'b) t -> f:(key:'a key -> data:'b -> bool) -> bool val exists : (_ , 'b) t -> f:( 'b -> bool) -> bool val for_alli : ('a, 'b) t -> f:(key:'a key -> data:'b -> bool) -> bool val for_all : (_ , 'b) t -> f:( 'b -> bool) -> bool val length : (_, _) t -> int val is_empty : (_, _) t -> bool val mem : ('a, _) t -> 'a key -> bool val remove : ('a, _) t -> 'a key -> unit (* [remove_one t key] if [key] is present in the table, and [data] is has at least two elements then replace [key] with [List.tl data], otherwise remove [key] *) val remove_one : ('a, _ list) t -> 'a key -> unit val replace : ('a, 'b) t -> key:'a key -> data:'b -> unit val set : ('a, 'b) t -> key:'a key -> data:'b -> unit val add : ('a, 'b) t -> key:'a key -> data:'b -> [ `Ok | `Duplicate ] val add_or_error : ('a, 'b) t -> key:'a key -> data:'b -> unit Or_error.t val add_exn : ('a, 'b) t -> key:'a key -> data:'b -> unit (** [change t key f] updates the given table by changing the value stored under [key] according to [f], just like [Map.change] (see that for example). *) val change : ('a, 'b) t -> 'a key -> ('b option -> 'b option) -> unit (** [add_multi t ~key ~data] if [key] is present in the table then cons [data] on the list, otherwise add [key] with a single element list. *) val add_multi : ('a, 'b list) t -> key:'a key -> data:'b -> unit (** [remove_multi t key] updates the table, removing the head of the list bound to [key]. If the list has only one element (or is empty) then the binding is removed. *) val remove_multi : ('a, _ list) t -> 'a key -> unit (** [map t f] returns new table with bound values replaced by [f] applied to the bound values *) val map : ('c, ('a, 'b) t -> f:('b -> 'c) -> ('a, 'c) t) map_options (** like [map], but function takes both key and data as arguments *) val mapi : ('c, ('a, 'b) t -> f:(key:'a key -> data:'b -> 'c) -> ('a, 'c) t) map_options (** returns new map with bound values filtered by f applied to the bound values *) val filter_map : ('c, ('a, 'b) t -> f:('b -> 'c option) -> ('a, 'c) t) map_options (** like [filter_map], but function takes both key and data as arguments*) val filter_mapi : ('c, ('a, 'b) t -> f:(key:'a key -> data:'b -> 'c option) -> ('a, 'c) t) map_options val filter : ('a, 'b) t -> f:('b -> bool) -> ('a, 'b) t val filteri : ('a, 'b) t -> f:(key:'a key -> data:'b -> bool) -> ('a, 'b) t (** returns new maps with bound values partitioned by f applied to the bound values *) val partition_map : ('c, ('d, ('a, 'b) t -> f:('b -> [`Fst of 'c | `Snd of 'd]) -> ('a, 'c) t * ('a, 'd) t) map_options) map_options (** like [partition_map], but function takes both key and data as arguments*) val partition_mapi : ('c, ('d, ('a, 'b) t -> f:(key:'a key -> data:'b -> [`Fst of 'c | `Snd of 'd]) -> ('a, 'c) t * ('a, 'd) t) map_options) map_options val partition_tf : ('a, 'b) t -> f:('b -> bool) -> ('a, 'b) t * ('a, 'b) t val partitioni_tf : ('a, 'b) t -> f:(key:'a key -> data:'b -> bool) -> ('a, 'b) t * ('a, 'b) t (** [find_or_add t k ~default] returns the data associated with key k if it is in the table t, otherwise it lets d = default() and adds it to the table. *) val find_or_add : ('a, 'b) t -> 'a key -> default:(unit -> 'b) -> 'b (** [find t k] returns Some (the current binding) of k in t, or None if no such binding exists *) val find : ('a, 'b) t -> 'a key -> 'b option (** [find_exn t k] returns the current binding of k in t, or raises Not_found if no such binding exists.*) val find_exn : ('a, 'b) t -> 'a key -> 'b (** [find_and_call t k ~if_found ~if_not_found] is equivalent to: [match find t k with Some v -> if_found v | None -> if_not_found k] except that it doesn't allocate the option. *) val find_and_call : ('a, 'b) t -> 'a key -> if_found:('b -> 'c) -> if_not_found:('a key -> 'c) -> 'c (** [find_and_remove t k] returns Some (the current binding) of k in t and removes it, or None is no such binding exists *) val find_and_remove : ('a, 'b) t -> 'a key -> 'b option (** [iter_vals t ~f] is like iter, except it only supplies the value to f, not the key. *) val iter_vals : (_, 'b) t -> f:('b -> unit) -> unit (** Merge two hashtables. The result of [merge f h1 h2] has as keys the set of all [k] in the union of the sets of keys of [h1] and [h2] for which [d(k)] is not None, where: d(k) = - f ~key:k (Some d1) None if [k] in [h1] is to d1, and [h2] does not map [k]; - f ~key:k None (Some d2) if [k] in [h2] is to d2, and [h1] does not map [k]; - f ~key:k (Some d1) (Some d2) otherwise, where [k] in [h1] is to [d1] and [k] in [h2] is to [d2]. Each key [k] is mapped to a single piece of data x, where [d(k)] = Some x. *) val merge : ('c, ('k, 'a) t -> ('k, 'b) t -> f:(key:'k key -> [ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] -> 'c option) -> ('k, 'c) t) map_options (** Merge one hashtable into another. After [merge_into f src dst], for every [key] in [src], [key] will be re-mapped in [dst] to [v] if [f ~key d1 (find dst key) = Some v]. *) val merge_into : f:(key:'a key -> 'b -> 'c option -> 'c option) -> src:('a, 'b) t -> dst:('a, 'c) t -> unit (** Returns the list of all keys for given hashtable. *) val keys : ('a, _) t -> 'a key list (** Returns the list of all data for given hashtable. *) val data : (_, 'b) t -> 'b list (** [filter_inplace t ~f] removes all the elements from [t] that don't satisfy [f]. *) val filter_inplace : (_, 'b) t -> f:('b -> bool) -> unit val filteri_inplace : ('a, 'b) t -> f:('a key -> 'b -> bool) -> unit (** [equal t1 t2 f] and [similar t1 t2 f] both return true iff [t1] and [t2] have the same keys and for all keys [k], [f (find_exn t1 k) (find_exn t2 k)]. [equal] and [similar] only differ in their types. *) val equal : ('a, 'b ) t -> ('a, 'b ) t -> ('b -> 'b -> bool) -> bool val similar : ('a, 'b1) t -> ('a, 'b2) t -> ('b1 -> 'b2 -> bool) -> bool (** Returns the list of all (key,data) pairs for given hashtable. *) val to_alist : ('a, 'b) t -> ('a key * 'b) list val validate : name:('a key -> string) -> 'b Validate.check -> ('a, 'b) t Validate.check val incr : ?by:int -> ('a, int) t -> 'a key -> unit end type ('key, 'data, 'z) create_options_without_hashable = ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 128 *) -> 'z type ('key, 'data, 'z) create_options_with_hashable = ?growth_allowed:bool (** defaults to [true] *) -> ?size:int (** initial size -- default 128 *) -> hashable:'key Hashable.t -> 'z module type Creators = sig type ('a, 'b) t type 'a key type ('key, 'data, 'z) create_options val create : ('a key, 'b, unit -> ('a, 'b) t) create_options val of_alist : ('a key, 'b, ('a key * 'b) list -> [ `Ok of ('a, 'b) t | `Duplicate_key of 'a key ]) create_options val of_alist_report_all_dups : ('a key, 'b, ('a key * 'b) list -> [ `Ok of ('a, 'b) t | `Duplicate_keys of 'a key list ]) create_options val of_alist_or_error : ('a key, 'b, ('a key * 'b) list -> ('a, 'b) t Or_error.t) create_options val of_alist_exn : ('a key, 'b, ('a key * 'b) list -> ('a, 'b) t) create_options val of_alist_multi : ('a key, 'b list, ('a key * 'b) list -> ('a, 'b list) t) create_options (** {[ create_mapped get_key get_data [x1,...,xn] = of_alist [get_key x1, get_data x1; ...; get_key xn, get_data xn] ]} *) val create_mapped : ('a key, 'b, get_key:('r -> 'a key) -> get_data:('r -> 'b) -> 'r list -> [ `Ok of ('a, 'b) t | `Duplicate_keys of 'a key list ]) create_options (** {[ create_with_key ~get_key [x1,...,xn] = of_alist [get_key x1, x1; ...; get_key xn, xn] ]} *) val create_with_key : ('a key, 'r, get_key:('r -> 'a key) -> 'r list -> [ `Ok of ('a, 'r) t | `Duplicate_keys of 'a key list ]) create_options val create_with_key_or_error : ('a key, 'r, get_key:('r -> 'a key) -> 'r list -> ('a, 'r) t Or_error.t) create_options val create_with_key_exn : ('a key, 'r, get_key:('r -> 'a key) -> 'r list -> ('a, 'r) t) create_options val group : ('a key, 'b, get_key:('r -> 'a key) -> get_data:('r -> 'b) -> combine:('b -> 'b -> 'b) -> 'r list -> ('a, 'b) t) create_options end module type S = sig type key type ('a, 'b) hashtbl type 'b t = (key, 'b) hashtbl with sexp type ('a, 'b) t_ = 'b t type 'a key_ = key val hashable : key Hashable.t include Creators with type ('a, 'b) t := ('a, 'b) t_ with type 'a key := 'a key_ with type ('key, 'data, 'z) create_options := ('key, 'data, 'z) create_options_without_hashable include Accessors with type ('a, 'b) t := ('a, 'b) t_ with type 'a key := 'a key_ with type ('a,'z) map_options := ('a,'z) no_map_options end module type S_binable = sig include S include Binable.S1 with type 'v t := 'v t end module type Hashtbl = sig module Hashable : Hashable val hash : 'a -> int val hash_param : int -> int -> 'a -> int type ('a, 'b) t with sexp_of (* We use [with sexp_of] but not [with sexp] because we want people to be explicit about the hash and comparison functions used when creating hashtables. One can use [Hashtbl.Poly.t], which does have [with sexp], to use polymorphic comparison and hashing. *) include Creators with type ('a, 'b) t := ('a, 'b) t with type 'a key = 'a with type ('a, 'b, 'z) create_options := ('a, 'b, 'z) create_options_with_hashable include Accessors with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a key with type ('a,'z) map_options := ('a,'z) no_map_options module Poly : sig type ('a, 'b) t with bin_io, sexp val hashable : 'a Hashable.t include Creators with type ('a, 'b) t := ('a, 'b) t with type 'a key = 'a with type ('key, 'data, 'z) create_options := ('key, 'data, 'z) create_options_without_hashable include Accessors with type ('a, 'b) t := ('a, 'b) t with type 'a key := 'a key with type ('a,'z) map_options := ('a,'z) no_map_options end with type ('a, 'b) t = ('a, 'b) t module type Key = Key module type Key_binable = Key_binable module type S = S with type ('a, 'b) hashtbl = ('a, 'b) t module type S_binable = S_binable with type ('a, 'b) hashtbl = ('a, 'b) t module Make (Key : Key ) : S with type key = Key.t module Make_binable (Key : Key_binable) : S_binable with type key = Key.t end core_kernel-113.00.00/src/core_int.ml000066400000000000000000000315501256461164500172450ustar00rootroot00000000000000open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std open Common module T = struct type t = int with bin_io, sexp, typerep (* According to estokes, if i = j then 0 else if i < j then -1 else 1 is only slightly faster, so we've decided to stick with Pervasives.compare *) let compare (x : t) y = compare x y let hash (x : t) = if x >= 0 then x else ~-x let of_string s = try int_of_string s with | _ -> failwithf "Int.of_string: %S" s () let to_string = string_of_int end include T let num_bits = Int_conversions.num_bits_int let to_float = Pervasives.float_of_int let of_float f = match Pervasives.classify_float f with | FP_normal | FP_subnormal | FP_zero -> Pervasives.int_of_float f | FP_infinite | FP_nan -> invalid_arg "Int.of_float on nan or inf" module Replace_polymorphic_compare = struct let min (x : t) y = if x < y then x else y let max (x : t) y = if x > y then x else y let compare = compare let ascending = compare let descending x y = compare y x let equal (x : t) y = x = y let ( >= ) (x : t) y = x >= y let ( <= ) (x : t) y = x <= y let ( = ) (x : t) y = x = y let ( > ) (x : t) y = x > y let ( < ) (x : t) y = x < y let ( <> ) (x : t) y = x <> y let between t ~low ~high = low <= t && t <= high let _squelch_unused_module_warning_ = () end include Replace_polymorphic_compare include Hashable.Make_binable (T) include Comparable.Map_and_set_binable (T) let zero = 0 let one = 1 let minus_one = -1 include Comparable.Validate_with_zero (struct include T let zero = zero end) let pred i = i - 1 let succ i = i + 1 let to_int i = i let to_int_exn = to_int let of_int i = i let of_int_exn = of_int let max_value = Pervasives.max_int let min_value = Pervasives.min_int module Conv = Int_conversions let of_int32 = Conv.int32_to_int let of_int32_exn = Conv.int32_to_int_exn let to_int32 = Conv.int_to_int32 let to_int32_exn = Conv.int_to_int32_exn let of_int64 = Conv.int64_to_int let of_int64_exn = Conv.int64_to_int_exn let to_int64 = Conv.int_to_int64 let of_nativeint = Conv.nativeint_to_int let of_nativeint_exn = Conv.nativeint_to_int_exn let to_nativeint = Conv.int_to_nativeint let to_nativeint_exn = to_nativeint include Conv.Make (T) include Conv.Make_hex(struct type t = int with bin_io, compare, typerep let zero = zero let neg = (~-) let (<) = (<) let to_string i = Printf.sprintf "%x" i let of_string s = Scanf.sscanf s "%x" Fn.id let module_name = "Core_kernel.Std.Int.Hex" end) TEST_MODULE "Hex" = struct let f (i,s_hum) = let s = Core_string.filter s_hum ~f:(fun c -> not (Core_char.equal c '_')) in let sexp_hum = Core_sexp.Atom s_hum in let sexp = Core_sexp.Atom s in <:test_result< Core_sexp.t >> ~message:"sexp_of_t" ~expect:sexp (Hex.sexp_of_t i); <:test_result< int >> ~message:"t_of_sexp" ~expect:i (Hex.t_of_sexp sexp); <:test_result< int >> ~message:"t_of_sexp[human]" ~expect:i (Hex.t_of_sexp sexp_hum); <:test_result< string >> ~message:"to_string" ~expect:s (Hex.to_string i); <:test_result< string >> ~message:"to_string_hum" ~expect:s_hum (Hex.to_string_hum i); <:test_result< int >> ~message:"of_string" ~expect:i (Hex.of_string s); <:test_result< int >> ~message:"of_string[human]" ~expect:i (Hex.of_string s_hum); ;; TEST_UNIT = Core_list.iter ~f [ 0, "0x0" ; 1, "0x1" ; 2, "0x2" ; 5, "0x5" ; 10, "0xa" ; 16, "0x10" ; 254, "0xfe" ; 65_535, "0xffff" ; 65_536, "0x1_0000" ; 1_000_000, "0xf_4240" ; -1, "-0x1" ; -2, "-0x2" ; -1_000_000, "-0xf_4240" ; max_value, (match num_bits with | 31 -> "0x3fff_ffff" | 32 -> "0x7fff_ffff" | 63 -> "0x3fff_ffff_ffff_ffff" | _ -> assert false) ; min_value, (match num_bits with | 31 -> "-0x4000_0000" | 32 -> "-0x8000_0000" | 63 -> "-0x4000_0000_0000_0000" | _ -> assert false) ] TEST_UNIT = <:test_result< int >> (Hex.of_string "0XA") ~expect:10 TEST_UNIT = match Option.try_with (fun () -> Hex.of_string "0") with | None -> () | Some _ -> failwith "Hex must always have a 0x prefix." TEST_UNIT = match Option.try_with (fun () -> Hex.of_string "0x_0") with | None -> () | Some _ -> failwith "Hex may not have '_' before the first digit." end let abs x = abs x let ( + ) x y = ( + ) x y let ( - ) x y = ( - ) x y let ( * ) x y = ( * ) x y let ( / ) x y = ( / ) x y let neg x = -x let ( ~- ) = neg TEST = (neg 5 + 5 = 0) (* note that rem is not same as % *) let rem a b = a mod b let incr = Pervasives.incr let decr = Pervasives.decr let shift_right a b = a asr b let shift_right_logical a b = a lsr b let shift_left a b = a lsl b let bit_not a = lnot a let bit_or a b = a lor b let bit_and a b = a land b let bit_xor a b = a lxor b let pow = Int_math.int_pow TEST = pow min_value 1 = min_value TEST = pow max_value 1 = max_value include Int_pow2 include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Core_kernel.Std.Int" end) module Pre_O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( ~- ) = ( ~- ) include (Replace_polymorphic_compare : Polymorphic_compare_intf.Infix with type t := t) let abs = abs let neg = neg let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O module F = Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) include F (* These inlined versions of (%), (/%), and (//) perform better than their functorized counterparts in [F] (see benchmarks below). The reason these functions are inlined in [Int] but not in any of the other integer modules is that they existed in [Int] and [Int] alone prior to the introduction of the [Int_math.Make] functor, and we didn't want to degrade their performance. We won't pre-emptively do the same for new functions, unless someone cares, on a case by case fashion. *) let ( % ) x y = if y <= zero then invalid_argf "%s %% %s in core_int.ml: modulus should be positive" (to_string x) (to_string y) (); let rval = rem x y in if rval < zero then rval + y else rval ;; let ( /% ) x y = if y <= zero then invalid_argf "%s /%% %s in core_int.ml: divisor should be positive" (to_string x) (to_string y) (); if x < zero then (x + one) / y - one else x / y ;; let (//) x y = to_float x /. to_float y ;; end BENCH_MODULE "Core_int_inline_ops" = struct (* The [of_string] and [Random.bool] are so that the values won't get inlined. *) let small = of_string "37" let big = of_string "123456789" let max = if Random.bool () then max_value else max_value let min = if Random.bool () then min_value else min_value BENCH "inlined % 01" = O.(%) big small BENCH "functor % 01" = O.F.(%) big small BENCH "inlined /% 01" = O.(/%) big small BENCH "functor /% 01" = O.F.(/%) big small BENCH "inlined // 01" = O.(//) big small BENCH "functor // 01" = O.F.(//) big small BENCH "inlined % 11" = O.(%) small big BENCH "functor % 11" = O.F.(%) small big BENCH "inlined /% 11" = O.(/%) small big BENCH "functor /% 11" = O.F.(/%) small big BENCH "inlined // 11" = O.(//) small big BENCH "functor // 11" = O.F.(//) small big BENCH "inlined % 21" = O.(%) max small BENCH "functor % 21" = O.F.(%) max small BENCH "inlined /% 21" = O.(/%) max small BENCH "functor /% 21" = O.F.(/%) max small BENCH "inlined // 21" = O.(//) max small BENCH "functor // 21" = O.F.(//) max small BENCH "inlined % 31" = O.(%) min small BENCH "functor % 31" = O.F.(%) min small BENCH "inlined /% 31" = O.(/%) min small BENCH "functor /% 31" = O.F.(/%) min small BENCH "inlined // 31" = O.(//) min small BENCH "functor // 31" = O.F.(//) min small BENCH "inlined % 41" = O.(%) max big BENCH "functor % 41" = O.F.(%) max big BENCH "inlined /% 41" = O.(/%) max big BENCH "functor /% 41" = O.F.(/%) max big BENCH "inlined // 41" = O.(//) max big BENCH "functor // 41" = O.F.(//) max big BENCH "inlined % 51" = O.(%) min big BENCH "functor % 51" = O.F.(%) min big BENCH "inlined /% 51" = O.(/%) min big BENCH "functor /% 51" = O.F.(/%) min big BENCH "inlined // 51" = O.(//) min big BENCH "functor // 51" = O.F.(//) min big end (* Estimated testing time 6m (36 benchmarks x 10s). Change using -quota SECS. ┌─────────────────────────────────────────────────┬──────────┬─────────┬────────────┠│ Name │ Time/Run │ mWd/Run │ Percentage │ ├─────────────────────────────────────────────────┼──────────┼─────────┼────────────┤ │ [core_int.ml:Core_int_inline_ops] inlined % 01 │ 19.89ns │ │ 63.76% │ │ [core_int.ml:Core_int_inline_ops] functor % 01 │ 25.45ns │ │ 81.58% │ │ [core_int.ml:Core_int_inline_ops] inlined /% 01 │ 18.26ns │ │ 58.54% │ │ [core_int.ml:Core_int_inline_ops] functor /% 01 │ 23.72ns │ │ 76.03% │ │ [core_int.ml:Core_int_inline_ops] inlined // 01 │ 8.16ns │ 2.00w │ 26.16% │ │ [core_int.ml:Core_int_inline_ops] functor // 01 │ 12.27ns │ 6.00w │ 39.34% │ │ [core_int.ml:Core_int_inline_ops] inlined % 11 │ 17.24ns │ │ 55.26% │ │ [core_int.ml:Core_int_inline_ops] functor % 11 │ 23.86ns │ │ 76.48% │ │ [core_int.ml:Core_int_inline_ops] inlined /% 11 │ 17.10ns │ │ 54.81% │ │ [core_int.ml:Core_int_inline_ops] functor /% 11 │ 22.08ns │ │ 70.77% │ │ [core_int.ml:Core_int_inline_ops] inlined // 11 │ 8.13ns │ 2.00w │ 26.06% │ │ [core_int.ml:Core_int_inline_ops] functor // 11 │ 12.20ns │ 6.00w │ 39.11% │ │ [core_int.ml:Core_int_inline_ops] inlined % 21 │ 21.37ns │ │ 68.50% │ │ [core_int.ml:Core_int_inline_ops] functor % 21 │ 27.67ns │ │ 88.69% │ │ [core_int.ml:Core_int_inline_ops] inlined /% 21 │ 19.60ns │ │ 62.82% │ │ [core_int.ml:Core_int_inline_ops] functor /% 21 │ 25.78ns │ │ 82.64% │ │ [core_int.ml:Core_int_inline_ops] inlined // 21 │ 8.13ns │ 2.00w │ 26.06% │ │ [core_int.ml:Core_int_inline_ops] functor // 21 │ 12.18ns │ 6.00w │ 39.05% │ │ [core_int.ml:Core_int_inline_ops] inlined % 31 │ 22.94ns │ │ 73.53% │ │ [core_int.ml:Core_int_inline_ops] functor % 31 │ 31.20ns │ │ 100.00% │ │ [core_int.ml:Core_int_inline_ops] inlined /% 31 │ 20.74ns │ │ 66.48% │ │ [core_int.ml:Core_int_inline_ops] functor /% 31 │ 30.94ns │ │ 99.18% │ │ [core_int.ml:Core_int_inline_ops] inlined // 31 │ 8.14ns │ 2.00w │ 26.08% │ │ [core_int.ml:Core_int_inline_ops] functor // 31 │ 12.25ns │ 6.00w │ 39.25% │ │ [core_int.ml:Core_int_inline_ops] inlined % 41 │ 20.75ns │ │ 66.50% │ │ [core_int.ml:Core_int_inline_ops] functor % 41 │ 26.49ns │ │ 84.91% │ │ [core_int.ml:Core_int_inline_ops] inlined /% 41 │ 18.89ns │ │ 60.55% │ │ [core_int.ml:Core_int_inline_ops] functor /% 41 │ 24.83ns │ │ 79.59% │ │ [core_int.ml:Core_int_inline_ops] inlined // 41 │ 8.14ns │ 2.00w │ 26.10% │ │ [core_int.ml:Core_int_inline_ops] functor // 41 │ 12.12ns │ 6.00w │ 38.85% │ │ [core_int.ml:Core_int_inline_ops] inlined % 51 │ 21.57ns │ │ 69.15% │ │ [core_int.ml:Core_int_inline_ops] functor % 51 │ 29.50ns │ │ 94.56% │ │ [core_int.ml:Core_int_inline_ops] inlined /% 51 │ 20.03ns │ │ 64.21% │ │ [core_int.ml:Core_int_inline_ops] functor /% 51 │ 29.15ns │ │ 93.45% │ │ [core_int.ml:Core_int_inline_ops] inlined // 51 │ 8.14ns │ 2.00w │ 26.08% │ │ [core_int.ml:Core_int_inline_ops] functor // 51 │ 12.12ns │ 6.00w │ 38.85% │ └─────────────────────────────────────────────────┴──────────┴─────────┴────────────┘ *) include O (* [Int] and [Int.O] agree value-wise *) core_kernel-113.00.00/src/core_int.mli000066400000000000000000000022341256461164500174130ustar00rootroot00000000000000(** OCaml's native integer type. The number of bits in an integer is platform dependent, being 31-bits on a 32-bit platform, and 63-bits on a 64-bit platform. [int] is a signed integer type. [int]s are also subject to overflow, meaning that [Int.max_value + 1 = Int.min_value]. [int]s always fit in a machine word. *) include Int_intf.S with type t = int (** {9 Conversion functions} *) val of_int : int -> t val to_int : t -> int val of_int32 : int32 -> t option val to_int32 : t -> int32 option val of_int64 : int64 -> t option val of_int64_exn : int64 -> t val of_nativeint : nativeint -> t option val to_nativeint : t -> nativeint (** [ceil_pow2 x] returns the smallest power of 2 that is greater than or equal to [x]. The implementation may only be called for [x > 0]. Example: [ceil_pow2 17 = 32] *) val ceil_pow2 : int -> int (** [floor_pow2 x] returns the largest power of 2 that is less than or equal to [x]. The implementation may only be called for [x > 0]. Example: [floor_pow2 17 = 16] *) val floor_pow2 : int -> int (** [is_pow2 x] returns true iff [x] is a power of 2. [is_pow2] raises if [x <= 0]. *) val is_pow2 : int -> bool core_kernel-113.00.00/src/core_int32.ml000066400000000000000000000064141256461164500174130ustar00rootroot00000000000000open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std open Int32 module T = struct type t = int32 with sexp, bin_io, typerep let compare (x : t) y = compare x y let hash (x : t) = Hashtbl.hash x let to_string = to_string let of_string = of_string end include T let num_bits = 32 let float_of_bits = float_of_bits let bits_of_float = bits_of_float let shift_right_logical = shift_right_logical let shift_right = shift_right let shift_left = shift_left let bit_not = lognot let bit_xor = logxor let bit_or = logor let bit_and = logand let min_value = min_int let max_value = max_int let abs = abs let pred = pred let succ = succ let rem = rem let neg = neg let minus_one = minus_one let one = one let zero = zero let compare = compare let to_float = to_float let of_float = of_float include Comparable.Validate_with_zero (struct include T let zero = zero end) module Replace_polymorphic_compare = struct let compare = compare let ascending = compare let descending x y = compare y x let min (x : t) y = if x < y then x else y let max (x : t) y = if x > y then x else y let equal (x : t) y = x = y let ( >= ) (x : t) y = x >= y let ( <= ) (x : t) y = x <= y let ( = ) (x : t) y = x = y let ( > ) (x : t) y = x > y let ( < ) (x : t) y = x < y let ( <> ) (x : t) y = x <> y let between t ~low ~high = low <= t && t <= high let _squelch_unused_module_warning_ = () end include Replace_polymorphic_compare include Hashable.Make_binable (T) include Comparable.Map_and_set_binable (T) let ( / ) = div let ( * ) = mul let ( - ) = sub let ( + ) = add let ( ~- ) = neg let incr r = r := !r + one let decr r = r := !r - one let of_int32 t = t let of_int32_exn = of_int32 let to_int32 t = t let to_int32_exn = to_int32 module Conv = Int_conversions let of_int = Conv.int_to_int32 let of_int_exn = Conv.int_to_int32_exn let to_int = Conv.int32_to_int let to_int_exn = Conv.int32_to_int_exn let of_int64 = Conv.int64_to_int32 let of_int64_exn = Conv.int64_to_int32_exn let to_int64 = Conv.int32_to_int64 let of_nativeint = Conv.nativeint_to_int32 let of_nativeint_exn = Conv.nativeint_to_int32_exn let to_nativeint = Conv.int32_to_nativeint let to_nativeint_exn = to_nativeint let pow b e = of_int_exn (Int_math.int_pow (to_int_exn b) (to_int_exn e)) include Conv.Make (T) include Conv.Make_hex(struct type t = int32 with bin_io, compare, typerep let zero = zero let neg = (~-) let (<) = (<) let to_string i = Printf.sprintf "%lx" i let of_string s = Scanf.sscanf s "%lx" Fn.id let module_name = "Core_kernel.Std.Int32.Hex" end) include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Core_kernel.Std.Int32" end) module Pre_O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( ~- ) = ( ~- ) include (Replace_polymorphic_compare : Polymorphic_compare_intf.Infix with type t := t) let abs = abs let neg = neg let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O include Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) end include O (* [Int32] and [Int32.O] agree value-wise *) core_kernel-113.00.00/src/core_int32.mli000066400000000000000000000014031256461164500175550ustar00rootroot00000000000000(** An int of exactly 32 bits, regardless of the machine. Side note: There's not much reason to want an int of at least 32 bits (i.e. 32 on 32-bit machines and 63 on 64-bit machines) because Int63 is basically just as efficient. Overflow issues are _not_ generally considered and explicitly handled. This may be more of an issue for 32-bit ints than 64-bit ints. [Int32.t] is boxed on both 32-bit and 64-bit machines. *) include Int_intf.S with type t = int32 val bits_of_float : float -> t val float_of_bits : t -> float val of_int : int -> t option val to_int : t -> int option val of_int32 : int32 -> t val to_int32 : t -> int32 val of_int64 : int64 -> t option val of_nativeint : nativeint -> t option val to_nativeint : t -> nativeint core_kernel-113.00.00/src/core_int63.ml000066400000000000000000000006761256461164500174230ustar00rootroot00000000000000INCLUDE "config.mlh" IFDEF ARCH_SIXTYFOUR THEN include Core_int let to_int x = Some x ELSE include Core_int64 ENDIF let () = assert (Core_int.(>=) num_bits 63) (* Even for ARCH_SIXTYFOUR, we can't use Core_random.State.int, because the bound is very limited in range. We actually want a bound that spans the type. *) let random ?(state = Core_random.State.default) bound = of_int64_exn (Core_random.State.int64 state (to_int64 bound)) ;; core_kernel-113.00.00/src/core_int63.mli000066400000000000000000000025561256461164500175730ustar00rootroot00000000000000(** 63 or 64 bit integers. The size of Int63 is always at least 63 bits. On a 64-bit platform it is just an int (63-bits), and on a 32-bit platform it is an int64. Because Int63 has different sizes on 32-bit and 64-bit platforms, there are several pitfalls to be aware of: - Int63 will behave differently in the case of overflow. - marshalling Int63 will not work between 32-bit and 64-bit platforms. unmarshal will segfault. - bin_io will work, except that it will raise an overflow exception when you send too large of an int from a 32-bit to a 64-bit platform. This is counterintuitive because the 32-bit platform has the larger int size. *) INCLUDE "config.mlh" IFDEF ARCH_SIXTYFOUR THEN (** We expose [private int] so that the compiler can omit caml_modify when dealing with record fields holding [Int63.t]. Code should not explicitly make use of the [private], e.g. via [(i :> int)], since such code will not compile on 32-bit platforms. *) include Int_intf.S with type t = private int ELSE include Int_intf.S ENDIF val of_int : int -> t val to_int : t -> int option (** [random ~state bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. The default [~state] is [Random.State.default]. *) val random : ?state : Core_random.State.t -> t -> t core_kernel-113.00.00/src/core_int64.ml000066400000000000000000000063441256461164500174220ustar00rootroot00000000000000open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std open Int64 module T = struct type t = int64 with sexp, bin_io, typerep let compare (x : t) y = compare x y let equal (x : t) y = x = y let hash (x : t) = Hashtbl.hash x let to_string = to_string let of_string = of_string end include T let num_bits = 64 let float_of_bits = float_of_bits let bits_of_float = bits_of_float let shift_right_logical = shift_right_logical let shift_right = shift_right let shift_left = shift_left let bit_not = lognot let bit_xor = logxor let bit_or = logor let bit_and = logand let min_value = min_int let max_value = max_int let abs = abs let pred = pred let succ = succ let pow = Int_math.int64_pow let rem = rem let neg = neg let minus_one = minus_one let one = one let zero = zero let compare = compare let to_float = to_float let of_float = of_float include Comparable.Validate_with_zero (struct include T let zero = zero end) module Replace_polymorphic_compare = struct let equal = equal let compare = compare let ascending = compare let descending x y = compare y x let min (x : t) y = if x < y then x else y let max (x : t) y = if x > y then x else y let ( >= ) (x : t) y = x >= y let ( <= ) (x : t) y = x <= y let ( = ) (x : t) y = x = y let ( > ) (x : t) y = x > y let ( < ) (x : t) y = x < y let ( <> ) (x : t) y = x <> y let between t ~low ~high = low <= t && t <= high let _squelch_unused_module_warning_ = () end include Replace_polymorphic_compare include Hashable.Make_binable (T) include Comparable.Map_and_set_binable (T) let ( / ) = div let ( * ) = mul let ( - ) = sub let ( + ) = add let ( ~- ) = neg let incr r = r := !r + one let decr r = r := !r - one let of_int64 t = t let of_int64_exn = of_int64 let to_int64 t = t module Conv = Int_conversions let of_int = Conv.int_to_int64 let of_int_exn = of_int let to_int = Conv.int64_to_int let to_int_exn = Conv.int64_to_int_exn let of_int32 = Conv.int32_to_int64 let of_int32_exn = of_int32 let to_int32 = Conv.int64_to_int32 let to_int32_exn = Conv.int64_to_int32_exn let of_nativeint = Conv.nativeint_to_int64 let of_nativeint_exn = of_nativeint let to_nativeint = Conv.int64_to_nativeint let to_nativeint_exn = Conv.int64_to_nativeint_exn include Conv.Make (T) include Conv.Make_hex(struct type t = int64 with bin_io, compare, typerep let zero = zero let neg = (~-) let (<) = (<) let to_string i = Printf.sprintf "%Lx" i let of_string s = Scanf.sscanf s "%Lx" Fn.id let module_name = "Core_kernel.Std.Int64.Hex" end) include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Core_kernel.Std.Int64" end) module Pre_O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( ~- ) = ( ~- ) include (Replace_polymorphic_compare : Polymorphic_compare_intf.Infix with type t := t) let abs = abs let neg = neg let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O include Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) end include O (* [Int64] and [Int64.O] agree value-wise *) core_kernel-113.00.00/src/core_int64.mli000066400000000000000000000005541256461164500175700ustar00rootroot00000000000000include Int_intf.S with type t = int64 val of_int : int -> t val to_int : t -> int option val of_float : float -> t val to_float : t -> float val of_int32 : int32 -> t val of_nativeint : nativeint -> t val bits_of_float : float -> t val float_of_bits : t -> float val to_int32 : t -> int32 option val to_nativeint : t -> nativeint option val of_int64 : t -> t core_kernel-113.00.00/src/core_kernel.mldylib000066400000000000000000000001401256461164500207460ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: e641c00a052b5410d80915ebedb701c5) Core_kernel # OASIS_STOP core_kernel-113.00.00/src/core_kernel.mllib000066400000000000000000000001401256461164500204110ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: e641c00a052b5410d80915ebedb701c5) Core_kernel # OASIS_STOP core_kernel-113.00.00/src/core_kernel.mlpack000066400000000000000000000053331256461164500205720ustar00rootroot00000000000000# OASIS_START # DO NOT EDIT (digest: b8e54dfb216a7f97ca208bcee28ece79) Applicative Applicative_intf Array_permute Avltree Backtrace Bag Bigbuffer_internal Bigbuffer Bigstring_marshal Bigstring Bigsubstring Binable0 Binable Binary_packing Binary_searchable Binary_searchable_intf Blang Blit Blit_intf Bool Bounded_int_table Bucket Byte_units Caml Common Commutative_group Comparable_intf Comparable Comparator Constrained_float Container Container_intf Container_unit_tests Core_arg Core_array Core_bin_prot Core_bytes Core_char Core_field Core_gc Core_gc_unit_tests Core_hashtbl_intf Core_hashtbl Core_int32 Core_int63 Core_int64 Core_int Core_lazy Core_list Core_list_unit_tests Core_map_intf Core_map Core_map_bench Core_map_unit_tests Core_nativeint Core_printexc Core_printf Core_queue Core_queue_debug Core_queue_unit_tests Core_random Core_set_intf Core_set Core_set_unit_tests Core_sexp Core_stack Core_string Core_weak Day_of_week Debug Decimal Deque Dequeue Doubly_linked Either Either_intf Equal Error Exn Fdeque Fheap Flags_intf Flags Flat_array Flat_array_debug Flat_array_unit_tests Flat_queue Flat_queue_debug Flat_queue_unit_tests Floatable Float_intf Float Float_robust_compare Fn Force_once Fqueue Hashable Hash_heap Hash_queue Hash_set_intf Hash_set Hashtbl_unit_tests Heap_block Heap_intf Heap Hex_lexer Host_and_port Identifiable In_channel Info Info_unit_tests Intable Int_conversions Interfaces Int_intf Int_math Int_pow2 Int_replace_polymorphic_compare Int_set Invariant Invariant_intf Linked_queue Linked_stack Make_substring Memo Monad Monad_intf Month Never_returns No_polymorphic_compare Nothing0 Nothing Obj_array Only_in_test Option Ordered_collection_common Ordering Or_error Out_channel Percent Perms Pid Poly Polymorphic_compare_intf Polymorphic_compare Pool Pool_intf Pool_unit_tests Pooled_hashtbl Pooled_hashtbl_unit_test Pow_overflow_bounds Pretty_printer Quickcheck Quickcheck_generator Quickcheck_intf Quickcheck_observer Quickcheck_unit_tests Raw_quickcheck_generator Raw_quickcheck_observer Ref Result Robustly_comparable Rope Sequence Set_once Sexpable Source_code_position0 Source_code_position Stable_containers Stable_internal Stable_module_types Stable Stable_unit_test_intf Stable_unit_test Stack_intf Stack_unit_tests Staged Std_common Std_internal Std_kernel Std Stringable String_id Substring_intf Substring T Thread_safe_queue Time_ns Time_ns_alternate_sexp Timing_wheel_intf Timing_wheel_ns Timing_wheel_ns_unit_tests Timing_wheel_unit_tests Total_map Tuple Tuple_type Tuple_type_intf Type_equal Type_immediacy Type_immediacy_conv_unit_tests Type_immediacy_witness_unit_tests Union_find Unique_id_intf Unique_id Unit Univ_map Univ_map_intf Univ Unpack_buffer Validated_intf Validated Validate With_return Word_size # OASIS_STOP core_kernel-113.00.00/src/core_lazy.ml000066400000000000000000000034441256461164500174330ustar00rootroot00000000000000open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std module Stable = struct module V1 = struct type 'a t = 'a lazy_t with bin_io, sexp, typerep let map t ~f = lazy (f (Lazy.force t)) let compare compare_a t1 t2 = compare_a (Lazy.force t1) (Lazy.force t2) end end include Stable.V1 include (Lazy : module type of Lazy with type 'a t := 'a t) include Monad.Make (struct type nonrec 'a t = 'a t let return x = from_val x let bind t f = lazy (force (f (force t))) let map = map let map = `Custom map end) TEST_MODULE = struct TEST_UNIT = let r = ref 0 in let t = return () >>= fun () -> incr r; return () in assert (!r = 0); force t; assert (!r = 1); force t; assert (!r = 1); ;; TEST_UNIT = let r = ref 0 in let t = return () >>= fun () -> lazy (incr r) in assert (!r = 0); force t; assert (!r = 1); force t; assert (!r = 1); ;; end module T_unforcing = struct type nonrec 'a t = 'a t let sexp_of_t sexp_of_a t = if is_val t then sexp_of_a (force t) else sexp_of_string "" ;; end TEST_MODULE = struct module M1 = struct type nonrec t = { x : int t } with sexp_of end module M2 = struct type t = { x : int T_unforcing.t } with sexp_of end TEST_UNIT = let v = lazy 42 in let (_ : int) = (* no needed, but the purpose of this test is not to test this compiler optimization *) force v in assert (is_val v); let t1 = { M1. x = v } in let t2 = { M2. x = v } in assert (M1.sexp_of_t t1 = M2.sexp_of_t t2); ;; TEST_UNIT = let t1 = { M1. x = lazy (40 + 2) } in let t2 = { M2. x = lazy (40 + 2) } in assert (M1.sexp_of_t t1 <> M2.sexp_of_t t2); assert (is_val t1.x); assert (not (is_val t2.x)); ;; end core_kernel-113.00.00/src/core_lazy.mli000066400000000000000000000053771256461164500176130ustar00rootroot00000000000000(* This file is a modified version of lazy.mli from the OCaml distribution. *) (** A value of type ['a Lazy.t] is a deferred computation, called a suspension, that has a result of type ['a]. The special expression syntax [lazy (expr)] makes a suspension of the computation of [expr], without computing [expr] itself yet. "Forcing" the suspension will then compute [expr] and return its result. Note: [lazy_t] is the built-in type constructor used by the compiler for the [lazy] keyword. You should not use it directly. Always use [Lazy.t] instead. Note: [Lazy.force] is not thread-safe. If you use this module in a multi-threaded program, you will need to add some locks. Note: if the program is compiled with the [-rectypes] option, ill-founded recursive definitions of the form [let rec x = lazy x] or [let rec x = lazy(lazy(...(lazy x)))] are accepted by the type-checker and lead, when forced, to ill-formed values that trigger infinite loops in the garbage collector and other parts of the run-time system. Without the [-rectypes] option, such ill-founded recursive definitions are rejected by the type-checker. *) type 'a t = 'a lazy_t with bin_io, compare, sexp, typerep include Monad.S with type 'a t := 'a t exception Undefined (** [force x] forces the suspension [x] and returns its result. If [x] has already been forced, [Lazy.force x] returns the same value again without recomputing it. If it raised an exception, the same exception is raised again. Raise [Undefined] if the forcing of [x] tries to force [x] itself recursively. *) external force : 'a t -> 'a = "%lazy_force" (** Like [force] except that if the computation of [x] raises an exception, it is unspecified whether [force_val x] raises the same exception or [Undefined]. *) val force_val : 'a t -> 'a (** [from_fun f] is the same as [lazy (f ())] but slightly more efficient. *) val from_fun : (unit -> 'a) -> 'a t (** [from_val v] returns an already-forced suspension of [v] This is for special purposes only and should not be confused with [lazy (v)]. *) val from_val : 'a -> 'a t (** [is_val x] returns [true] if [x] has already been forced and did not raise an exception. *) val is_val : 'a t -> bool (** This type offers a serialization function [sexp_of_t] that won't force its argument. Instead, it will serialize the ['a] if it is available, or just use a custom string indicating is not forced. Note that this is not a round-trippable type, thus the type does not expose [of_sexp]. To be used in debug code for example, or while tracking an Heisenbug, etc. *) module T_unforcing : sig type nonrec 'a t = 'a t with sexp_of end module Stable : sig module V1 : Stable_module_types.S1 with type 'a t = 'a t end core_kernel-113.00.00/src/core_list.ml000066400000000000000000001061771256461164500174360ustar00rootroot00000000000000module List = StdLabels.List module String = StdLabels.String open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std module Random = Core_random let invalid_argf = Core_printf.invalid_argf module T = struct type 'a t = 'a list with sexp, bin_io, typerep end include T let of_list t = t let range ?(stride=1) ?(start=`inclusive) ?(stop=`exclusive) start_i stop_i = if stride = 0 then invalid_arg "Core_list.range: stride must be non-zero"; (* Generate the range from the last element, so that we do not need to rev it *) let rec loop last counter accum = if counter <= 0 then accum else loop (last - stride) (counter - 1) (last :: accum) in let stride_sign = if stride > 0 then 1 else -1 in let start = match start with | `inclusive -> start_i | `exclusive -> start_i + stride in let stop = match stop with | `inclusive -> stop_i + stride_sign | `exclusive -> stop_i in let num_elts = (stop - start + stride - stride_sign) / stride in loop (start + (stride * (num_elts - 1))) num_elts [] ;; TEST_MODULE "range symmetries" = struct let basic ~stride ~start ~stop ~start_n ~stop_n ~result = range ~stride ~start ~stop start_n stop_n = result let test stride (start_n, start) (stop_n, stop) result = basic ~stride ~start ~stop ~start_n ~stop_n ~result && (* works for negative [start] and [stop] *) basic ~stride:(-stride) ~start_n:(-start_n) ~stop_n:(-stop_n) ~start ~stop ~result:(List.map result ~f:(fun x -> -x)) TEST = test 1 ( 3, `inclusive) ( 1, `exclusive) [] TEST = test 1 ( 3, `inclusive) ( 3, `exclusive) [] TEST = test 1 ( 3, `inclusive) ( 4, `exclusive) [3] TEST = test 1 ( 3, `inclusive) ( 8, `exclusive) [3;4;5;6;7] TEST = test 3 ( 4, `inclusive) (10, `exclusive) [4;7] TEST = test 3 ( 4, `inclusive) (11, `exclusive) [4;7;10] TEST = test 3 ( 4, `inclusive) (12, `exclusive) [4;7;10] TEST = test 3 ( 4, `inclusive) (13, `exclusive) [4;7;10] TEST = test 3 ( 4, `inclusive) (14, `exclusive) [4;7;10;13] TEST = test (-1) ( 1, `inclusive) ( 3, `exclusive) [] TEST = test (-1) ( 3, `inclusive) ( 3, `exclusive) [] TEST = test (-1) ( 4, `inclusive) ( 3, `exclusive) [4] TEST = test (-1) ( 8, `inclusive) ( 3, `exclusive) [8;7;6;5;4] TEST = test (-3) (10, `inclusive) ( 4, `exclusive) [10;7] TEST = test (-3) (10, `inclusive) ( 3, `exclusive) [10;7;4] TEST = test (-3) (10, `inclusive) ( 2, `exclusive) [10;7;4] TEST = test (-3) (10, `inclusive) ( 1, `exclusive) [10;7;4] TEST = test (-3) (10, `inclusive) ( 0, `exclusive) [10;7;4;1] TEST = test 1 ( 3, `exclusive) ( 1, `exclusive) [] TEST = test 1 ( 3, `exclusive) ( 3, `exclusive) [] TEST = test 1 ( 3, `exclusive) ( 4, `exclusive) [] TEST = test 1 ( 3, `exclusive) ( 8, `exclusive) [4;5;6;7] TEST = test 3 ( 4, `exclusive) (10, `exclusive) [7] TEST = test 3 ( 4, `exclusive) (11, `exclusive) [7;10] TEST = test 3 ( 4, `exclusive) (12, `exclusive) [7;10] TEST = test 3 ( 4, `exclusive) (13, `exclusive) [7;10] TEST = test 3 ( 4, `exclusive) (14, `exclusive) [7;10;13] TEST = test (-1) ( 1, `exclusive) ( 3, `exclusive) [] TEST = test (-1) ( 3, `exclusive) ( 3, `exclusive) [] TEST = test (-1) ( 4, `exclusive) ( 3, `exclusive) [] TEST = test (-1) ( 8, `exclusive) ( 3, `exclusive) [7;6;5;4] TEST = test (-3) (10, `exclusive) ( 4, `exclusive) [7] TEST = test (-3) (10, `exclusive) ( 3, `exclusive) [7;4] TEST = test (-3) (10, `exclusive) ( 2, `exclusive) [7;4] TEST = test (-3) (10, `exclusive) ( 1, `exclusive) [7;4] TEST = test (-3) (10, `exclusive) ( 0, `exclusive) [7;4;1] TEST = test 1 ( 3, `inclusive) ( 1, `inclusive) [] TEST = test 1 ( 3, `inclusive) ( 3, `inclusive) [3] TEST = test 1 ( 3, `inclusive) ( 4, `inclusive) [3;4] TEST = test 1 ( 3, `inclusive) ( 8, `inclusive) [3;4;5;6;7;8] TEST = test 3 ( 4, `inclusive) (10, `inclusive) [4;7;10] TEST = test 3 ( 4, `inclusive) (11, `inclusive) [4;7;10] TEST = test 3 ( 4, `inclusive) (12, `inclusive) [4;7;10] TEST = test 3 ( 4, `inclusive) (13, `inclusive) [4;7;10;13] TEST = test 3 ( 4, `inclusive) (14, `inclusive) [4;7;10;13] TEST = test (-1) ( 1, `inclusive) ( 3, `inclusive) [] TEST = test (-1) ( 3, `inclusive) ( 3, `inclusive) [3] TEST = test (-1) ( 4, `inclusive) ( 3, `inclusive) [4;3] TEST = test (-1) ( 8, `inclusive) ( 3, `inclusive) [8;7;6;5;4;3] TEST = test (-3) (10, `inclusive) ( 4, `inclusive) [10;7;4] TEST = test (-3) (10, `inclusive) ( 3, `inclusive) [10;7;4] TEST = test (-3) (10, `inclusive) ( 2, `inclusive) [10;7;4] TEST = test (-3) (10, `inclusive) ( 1, `inclusive) [10;7;4;1] TEST = test (-3) (10, `inclusive) ( 0, `inclusive) [10;7;4;1] TEST = test 1 ( 3, `exclusive) ( 1, `inclusive) [] TEST = test 1 ( 3, `exclusive) ( 3, `inclusive) [] TEST = test 1 ( 3, `exclusive) ( 4, `inclusive) [4] TEST = test 1 ( 3, `exclusive) ( 8, `inclusive) [4;5;6;7;8] TEST = test 3 ( 4, `exclusive) (10, `inclusive) [7;10] TEST = test 3 ( 4, `exclusive) (11, `inclusive) [7;10] TEST = test 3 ( 4, `exclusive) (12, `inclusive) [7;10] TEST = test 3 ( 4, `exclusive) (13, `inclusive) [7;10;13] TEST = test 3 ( 4, `exclusive) (14, `inclusive) [7;10;13] TEST = test (-1) ( 1, `exclusive) ( 3, `inclusive) [] TEST = test (-1) ( 3, `exclusive) ( 3, `inclusive) [] TEST = test (-1) ( 4, `exclusive) ( 3, `inclusive) [3] TEST = test (-1) ( 8, `exclusive) ( 3, `inclusive) [7;6;5;4;3] TEST = test (-3) (10, `exclusive) ( 4, `inclusive) [7;4] TEST = test (-3) (10, `exclusive) ( 3, `inclusive) [7;4] TEST = test (-3) (10, `exclusive) ( 2, `inclusive) [7;4] TEST = test (-3) (10, `exclusive) ( 1, `inclusive) [7;4;1] TEST = test (-3) (10, `exclusive) ( 0, `inclusive) [7;4;1] let test_start_inc_exc stride start (stop, stop_inc_exc) result = test stride (start, `inclusive) (stop, stop_inc_exc) result && begin match result with | [] -> true | head :: tail -> head = start && test stride (start, `exclusive) (stop, stop_inc_exc) tail end let test_inc_exc stride start stop result = test_start_inc_exc stride start (stop, `inclusive) result && begin match List.rev result with | [] -> true | last :: all_but_last -> let all_but_last = List.rev all_but_last in if last = stop then test_start_inc_exc stride start (stop, `exclusive) all_but_last else true end TEST = test_inc_exc 1 4 10 [4;5;6;7;8;9;10] TEST = test_inc_exc 3 4 10 [4;7;10] TEST = test_inc_exc 3 4 11 [4;7;10] TEST = test_inc_exc 3 4 12 [4;7;10] TEST = test_inc_exc 3 4 13 [4;7;10;13] TEST = test_inc_exc 3 4 14 [4;7;10;13] end module Test_values = struct let long1 = let v = lazy (range 1 100_000) in fun () -> Lazy.force v let l1 = [1;2;3;4;5;6;7;8;9;10] end (* Standard functions *) let length = List.length let hd_exn = List.hd let tl_exn = List.tl let hd t = match t with | [] -> None | x :: _ -> Some x ;; let tl t = match t with | [] -> None | _ :: t' -> Some t' ;; let nth t n = if n < 0 then None else let rec nth_aux t n = match t with | [] -> None | a :: t -> if n = 0 then Some a else nth_aux t (n-1) in nth_aux t n ;; let nth_exn t n = match nth t n with | None -> invalid_argf "List.nth_exn %d called on list of length %d" n (length t) () | Some a -> a ;; let rev_append = List.rev_append TEST = rev_append [1;2;3] [4;5;6] = [3;2;1;4;5;6] TEST = rev_append [] [4;5;6] = [4;5;6] TEST = rev_append [1;2;3] [] = [3;2;1] TEST = rev_append [1] [2;3] = [1;2;3] TEST = rev_append [1;2] [3] = [2;1;3] TEST = let long = Test_values.long1 () in ignore (rev_append long long:int list); true let rev = function | [] | [_] as res -> res | x :: y :: rest -> rev_append rest [y; x] let unordered_append l1 l2 = match l1, l2 with | [], l | l, [] -> l | _ -> List.rev_append l1 l2 let rev_map t ~f = List.rev_map t ~f exception Length_mismatch of string * int * int with sexp let check_length2 name l1 l2 = let n1 = length l1 in let n2 = length l2 in if n1 <> n2 then raise (invalid_argf "length mismatch in %s: %d <> %d " name n1 n2 ()) ;; let check_length3 name l1 l2 l3 = let n1 = length l1 in let n2 = length l2 in let n3 = length l3 in if n1 <> n2 || n2 <> n3 then raise (invalid_argf "length mismatch in %s: %d <> %d || %d <> %d" name n1 n2 n2 n3 ()) ;; let iter2_exn l1 l2 ~f = check_length2 "iter2_exn" l1 l2; List.iter2 l1 l2 ~f; ;; let rev_map2_exn l1 l2 ~f = check_length2 "rev_map2_exn" l1 l2; List.rev_map2 l1 l2 ~f; ;; let fold2_exn l1 l2 ~init ~f = check_length2 "fold2_exn" l1 l2; List.fold_left2 l1 l2 ~init ~f; ;; let for_all2_exn l1 l2 ~f = check_length2 "for_all2_exn" l1 l2; List.for_all2 l1 l2 ~f; ;; TEST = for_all2_exn [] [] ~f:(fun _ _ -> assert false) let exists2_exn l1 l2 ~f = check_length2 "exists2_exn" l1 l2; List.exists2 l1 l2 ~f; ;; let mem ?(equal = (=)) t a = List.exists t ~f:(equal a) (* This is a copy of the code from the standard library, with an extra eta-expansion to avoid creating partial closures (showed up for List.filter in profiling). *) let rev_filter t ~f = let rec find ~f accu = function | [] -> accu | x :: l -> if f x then find ~f (x :: accu) l else find ~f accu l in find ~f [] t ;; let filter t ~f = rev (rev_filter t ~f) let sort = List.sort let stable_sort = List.stable_sort let find_map t ~f = let rec loop = function | [] -> None | x :: l -> match f x with | None -> loop l | Some _ as r -> r in loop t ;; let find t ~f = let rec loop = function | [] -> None | x :: l -> if f x then Some x else loop l in loop t ;; let find_exn t ~f = List.find t ~f let findi t ~f = let rec loop i t = match t with | [] -> None | x :: l -> if f i x then Some (i, x) else loop (i + 1) l in loop 0 t ;; (** changing the order of arguments on some standard [List] functions. *) let exists t ~f = List.exists t ~f let for_all t ~f = List.for_all t ~f let iter t ~f = List.iter t ~f (** For the container interface. *) let fold t ~init ~f = List.fold_left t ~f ~init let fold_left = fold let to_array = Caml.Array.of_list let to_list t = t (** Tail recursive versions of standard [List] module *) let slow_append l1 l2 = List.rev_append (List.rev l1) l2 (* There are a few optimized list operations here, including append and map. There are basically two optimizations in play: loop unrolling, and dynamic switching between stack and heap allocation. The loop-unrolling is straightforward, we just unroll 5 levels of the loop. This makes each iteration faster, and also reduces the number of stack frames consumed per list element. The dynamic switching is done by counting the number of stack frames, and then switching to the "slow" implementation when we exceed a given limit. This means that short lists use the fast stack-allocation method, and long lists use a slower one that doesn't require stack space. *) let rec count_append l1 l2 count = match l2 with | [] -> l1 | _ -> match l1 with | [] -> l2 | [x1] -> x1 :: l2 | [x1; x2] -> x1 :: x2 :: l2 | [x1; x2; x3] -> x1 :: x2 :: x3 :: l2 | [x1; x2; x3; x4] -> x1 :: x2 :: x3 :: x4 :: l2 | x1 :: x2 :: x3 :: x4 :: x5 :: tl -> x1 :: x2 :: x3 :: x4 :: x5 :: (if count > 1000 then slow_append tl l2 else count_append tl l2 (count + 1)) let append l1 l2 = count_append l1 l2 0 TEST = append [1;2;3] [4;5;6] = [1;2;3;4;5;6] TEST = append [] [4;5;6] = [4;5;6] TEST = append [1;2;3] [] = [1;2;3] TEST = append [1] [2;3] = [1;2;3] TEST = append [1;2] [3] = [1;2;3] TEST_UNIT = let long = Test_values.long1 () in ignore (append long long:int list) let map_slow l ~f = List.rev (List.rev_map ~f l) let rec count_map ~f l ctr = match l with | [] -> [] | [x1] -> let f1 = f x1 in [f1] | [x1; x2] -> let f1 = f x1 in let f2 = f x2 in [f1; f2] | [x1; x2; x3] -> let f1 = f x1 in let f2 = f x2 in let f3 = f x3 in [f1; f2; f3] | [x1; x2; x3; x4] -> let f1 = f x1 in let f2 = f x2 in let f3 = f x3 in let f4 = f x4 in [f1; f2; f3; f4] | x1 :: x2 :: x3 :: x4 :: x5 :: tl -> let f1 = f x1 in let f2 = f x2 in let f3 = f x3 in let f4 = f x4 in let f5 = f x5 in f1 :: f2 :: f3 :: f4 :: f5 :: (if ctr > 1000 then map_slow ~f tl else count_map ~f tl (ctr + 1)) let map l ~f = count_map ~f l 0 TEST = map ~f:(fun x -> x) Test_values.l1 = Test_values.l1 TEST = map ~f:(fun x -> x) [] = [] TEST = map ~f:(fun x -> x +. 5.) [1.;2.;3.] = [6.;7.;8.] TEST_UNIT = ignore (map ~f:(fun x -> x) (Test_values.long1 ()):int list) let (>>|) l f = map l ~f let map2_exn l1 l2 ~f = List.rev (rev_map2_exn l1 l2 ~f) TEST = map2_exn ~f:(fun a b -> a, b) [1;2;3] ['a';'b';'c'] = [(1,'a'); (2,'b'); (3,'c')] TEST = map2_exn ~f:(fun _ _ -> ()) [] [] = [] TEST_UNIT = let long = Test_values.long1 () in ignore (map2_exn ~f:(fun _ _ -> ()) long long:unit list) let rev_map3_exn l1 l2 l3 ~f = check_length3 "rev_map3" l1 l2 l3; let rec loop l1 l2 l3 ac = match (l1, l2, l3) with | ([], [], []) -> ac | (x1 :: l1, x2 :: l2, x3 :: l3) -> loop l1 l2 l3 (f x1 x2 x3 :: ac) | _ -> assert false in loop l1 l2 l3 [] ;; let map3_exn l1 l2 l3 ~f = List.rev (rev_map3_exn l1 l2 l3 ~f) let rec rev_map_append l1 l2 ~f = match l1 with | [] -> l2 | h :: t -> rev_map_append ~f t (f h :: l2) TEST = rev_map_append [1;2;3;4;5] [6] ~f:(fun x -> x) = [5;4;3;2;1;6] TEST = rev_map_append [1;2;3;4;5] [6] ~f:(fun x -> 2 * x) = [10;8;6;4;2;6] TEST = rev_map_append [] [6] ~f:(fun _ -> failwith "bug!") = [6] let fold_right l ~f ~init = fold ~f:(fun a b -> f b a) ~init (List.rev l) TEST = fold_right ~f:(fun e acc -> e :: acc) Test_values.l1 ~init:[] = Test_values.l1 TEST = fold_right ~f:(fun e acc -> e ^ acc) ["1";"2"] ~init:"3" = "123" TEST = fold_right ~f:(fun _ _ -> ()) [] ~init:() = () TEST_UNIT = let long = Test_values.long1 () in ignore (fold_right ~f:(fun e acc -> e :: acc) long ~init:[]) let unzip list = let rec loop list l1 l2 = match list with | [] -> (List.rev l1, List.rev l2) | (x, y) :: tl -> loop tl (x :: l1) (y :: l2) in loop list [] [] let zip_exn l1 l2 = map2_exn ~f:(fun a b -> (a, b)) l1 l2 TEST = let l1 = Test_values.l1 in unzip (zip_exn l1 (List.rev l1)) = (l1, List.rev l1) ;; TEST_UNIT = let long = Test_values.long1 () in ignore (unzip (zip_exn long long)) ;; let zip l1 l2 = try Some (zip_exn l1 l2) with _ -> None TEST = zip [1;2;3] [4;5;6] = Some [1,4;2,5;3,6] TEST = zip [1] [4;5;6] = None (** Additional list operations *) let rev_mapi l ~f = let rec loop i acc = function | [] -> acc | h :: t -> loop (i + 1) (f i h :: acc) t in loop 0 [] l let mapi l ~f = List.rev (rev_mapi l ~f) TEST = mapi ~f:(fun i x -> (i,x)) ["one";"two";"three";"four"] = [0,"one";1,"two";2,"three";3,"four"] TEST = mapi ~f:(fun i x -> (i,x)) [] = [] let iteri l ~f = ignore (fold l ~init:0 ~f:(fun i x -> f i x; i + 1)); ;; let foldi t ~f ~init = snd (fold t ~init:(0, init) ~f:(fun (i, acc) v -> (i + 1, f i acc v))) ;; let filteri l ~f = List.rev (foldi l ~f:(fun pos acc x -> if f pos x then x :: acc else acc) ~init:[]) let reduce l ~f = match l with | [] -> None | hd :: tl -> Some (fold ~init:hd ~f tl) let reduce_exn l ~f = match reduce l ~f with | None -> raise (Invalid_argument "List.reduce_exn") | Some v -> v let reduce_balanced l ~f = (* Call the "size" of a value the number of list elements that have been combined into it via calls to [f]. We proceed by using [f] to combine elements in the accumulator of the same size until we can't combine any more, then getting a new element from the input list and repeating. With this strategy, in the accumulator: - we only ever have elements of sizes a power of two - we never have more than one element of each size - the sum of all the element sizes is equal to the number of elements consumed These conditions enforce that list of elements of each size is precisely the binary expansion of the number of elements consumed: if you've consumed 13 = 0b1101 elements, you have one element of size 8, one of size 4, and one of size 1. Hence when a new element comes along, the number of combinings you need to do is the number of trailing 1s in the binary expansion of [num], the number of elements that have already gone into the accumulator. The accumulator is in ascending order of size, so the next element to combine with is always the head of the list. *) let rec step_accum num acc x = if num land 1 = 0 then x :: acc else match acc with | [] -> assert false (* New elements from later in the input list go on the front of the accumulator, so the accumulator is in reverse order wrt the original list order, hence [f y x] instead of [f x y]. *) | y :: ys -> step_accum (num asr 1) ys (f y x) in (* Experimentally, inlining [foldi] and unrolling this loop a few times can reduce runtime down to a third and allocation to 1/16th or so in the microbenchmarks below. However, in most use cases [f] is likely to be expensive (otherwise why do you care about the order of reduction?) so the overhead of this function itself doesn't really matter. If you come up with a use-case where it does, then that's something you might want to try: see hg log -pr 49ef065f429d. *) match foldi l ~init:[] ~f:step_accum with | [] -> None | x :: xs -> Some (fold xs ~init:x ~f:(fun x y -> f y x)) let reduce_balanced_exn l ~f = match reduce_balanced l ~f with | None -> raise (Invalid_argument "List.reduce_balanced_exn") | Some v -> v TEST_MODULE "reduce_balanced" = struct let test expect list = <:test_result> ~expect (reduce_balanced ~f:(fun a b -> "(" ^ a ^ "+" ^ b ^ ")") list) TEST_UNIT "length 0" = test None [] TEST_UNIT "length 1" = test (Some "a") ["a"] TEST_UNIT "length 2" = test (Some "(a+b)") ["a"; "b"] TEST_UNIT "length 6" = test (Some "(((a+b)+(c+d))+(e+f))") ["a";"b";"c";"d";"e";"f"] TEST_UNIT "longer" = (* pairs (index, number of times f called on me) to check: 1. f called on results in index order 2. total number of calls on any element is low called on 2^n + 1 to demonstrate lack of balance (most elements are distance 7 from the tree root, but one is distance 1) *) let data = map (range 0 65) ~f:(fun i -> [(i, 0)]) in let f x y = map (x @ y) ~f:(fun (ix, cx) -> (ix, cx + 1)) in match reduce_balanced data ~f with | None -> failwith "None" | Some l -> <:test_result> ~expect:65 (List.length l); iteri l ~f:(fun actual_index (computed_index, num_f) -> let expected_num_f = if actual_index = 64 then 1 else 7 in <:test_result< int * int >> ~expect:(actual_index, expected_num_f) (computed_index, num_f)) end BENCH_INDEXED "reduce_balanced" i [5; 7; 9; 11; 13; 20] = let l = range 0 (1 lsl i) in fun () -> reduce_balanced l ~f:(+) BENCH_INDEXED "reduce_imbalanced" i [5; 7; 9; 11; 13; 20] = let l = range 0 (1 lsl i) in fun () -> reduce l ~f:(+) let groupi l ~break = let groups = foldi l ~init:[] ~f:(fun i acc x -> match acc with | [] -> [[x]] | current_group :: tl -> if break i (hd_exn current_group) x then [x] :: current_group :: tl (* start new group *) else (x :: current_group) :: tl) (* extend current group *) in match groups with | [] -> [] | l -> rev_map l ~f:rev let group l ~break = groupi l ~break:(fun _ x y -> break x y) TEST_MODULE "group" = struct TEST = (group [1;2;3;4] ~break:(fun _ x -> x = 3) = [[1;2];[3;4]]) TEST = (group [] ~break:(fun _ -> assert false)) = [] let mis = ['M';'i';'s';'s';'i';'s';'s';'i';'p';'p';'i'] let equal_letters = [['M'];['i'];['s';'s'];['i'];['s';'s'];['i'];['p';'p'];['i']] let single_letters = [['M';'i';'s';'s';'i';'s';'s';'i';'p';'p';'i']] let every_three = [['M'; 'i'; 's']; ['s'; 'i'; 's']; ['s'; 'i'; 'p']; ['p'; 'i' ]] TEST = (group ~break:(<>) mis) = equal_letters TEST = (group ~break:(fun _ _ -> false) mis) = single_letters TEST = (groupi ~break:(fun i _ _ -> i mod 3 = 0) mis) = every_three end let concat_map l ~f = let rec aux acc = function | [] -> List.rev acc | hd :: tl -> aux (rev_append (f hd) acc) tl in aux [] l let concat_mapi l ~f = let rec aux cont acc = function | [] -> List.rev acc | hd :: tl -> aux (cont + 1) (rev_append (f cont hd) acc) tl in aux 0 [] l let merge l1 l2 ~cmp = let rec loop acc l1 l2 = match l1,l2 with | [], l2 -> rev_append acc l2 | l1, [] -> rev_append acc l1 | h1 :: t1, h2 :: t2 -> if cmp h1 h2 <= 0 then loop (h1 :: acc) t1 l2 else loop (h2 :: acc) l1 t2 in loop [] l1 l2 ;; include struct (* We are explicit about what we import from the general Monad functor so that * we don't accidentally rebind more efficient list-specific functions. *) module Monad = Monad.Make (struct type 'a t = 'a list let bind x f = concat_map x ~f let map = `Custom map let return x = [x] end) open Monad module Monad_infix = Monad_infix let ignore_m = ignore_m let join = join let bind = bind let (>>=) = bind let return = return let all = all let all_ignore = all_ignore end (** returns final element of list *) let rec last_exn list = match list with | [x] -> x | _ :: tl -> last_exn tl | [] -> raise (Invalid_argument "Core_list.last") TEST = last_exn [1;2;3] = 3 TEST = last_exn [1] = 1 TEST = last_exn (Test_values.long1 ()) = 99_999 (** optionally returns final element of list *) let rec last list = match list with | [x] -> Some x | _ :: tl -> last tl | [] -> None ;; let rec is_prefix list ~prefix ~equal = match prefix with | [] -> true | hd::tl -> match list with | [] -> false | hd'::tl' -> equal hd hd' && is_prefix tl' ~prefix:tl ~equal ;; TEST = is_prefix [] ~prefix:[] ~equal:(=) TEST = is_prefix [1] ~prefix:[] ~equal:(=) TEST = is_prefix [1] ~prefix:[1] ~equal:(=) TEST = not (is_prefix [1] ~prefix:[1;2] ~equal:(=)) TEST = not (is_prefix [1;3] ~prefix:[1;2] ~equal:(=)) TEST = is_prefix [1;2;3] ~prefix:[1;2] ~equal:(=) let find_consecutive_duplicate t ~equal = match t with | [] -> None | a1 :: t -> let rec loop a1 t = match t with | [] -> None | a2 :: t -> if equal a1 a2 then Some (a1, a2) else loop a2 t in loop a1 t ;; TEST_UNIT = List.iter ~f:(fun (t, expect) -> assert (Poly.equal expect (find_consecutive_duplicate t ~equal:Poly.equal))) [ [] , None ; [ 1 ] , None ; [ 1; 1 ] , Some (1, 1) ; [ 1; 2 ] , None ; [ 1; 2; 1 ] , None ; [ 1; 2; 2 ] , Some (2, 2) ; [ 1; 1; 2; 2 ], Some (1, 1) ] ;; TEST = find_consecutive_duplicate [(0,'a');(1,'b');(2,'b')] ~equal:(fun (_, a) (_, b) -> Pervasives.(=) a b) = Some ((1, 'b'), (2, 'b')) ;; (* returns list without adjacent duplicates *) let remove_consecutive_duplicates list ~equal = let rec loop list accum = match list with | [] -> accum | hd :: [] -> hd :: accum | hd1 :: hd2 :: tl -> if equal hd1 hd2 then loop (hd2 :: tl) accum else loop (hd2 :: tl) (hd1 :: accum) in rev (loop list []) TEST = remove_consecutive_duplicates ~equal:Pervasives.(=) [] = [] TEST = remove_consecutive_duplicates ~equal:Pervasives.(=) [5;5;5;5;5] = [5] TEST = remove_consecutive_duplicates ~equal:Pervasives.(=) [5;6;5;6;5;6] = [5;6;5;6;5;6] TEST = remove_consecutive_duplicates ~equal:Pervasives.(=) [5;5;6;6;5;5;8;8] = [5;6;5;8] TEST = length (remove_consecutive_duplicates [(0,1);(0,2);(2,2);(4,1)] ~equal:(fun (a,_) (b,_) -> Pervasives.(=) a b)) = 3 TEST = length (remove_consecutive_duplicates [(0,1);(2,2);(0,2);(4,1)] ~equal:(fun (a,_) (b,_) -> Pervasives.(=) a b)) = 4 TEST = length (remove_consecutive_duplicates [(0,1);(2,1);(0,2);(4,2)] ~equal:(fun (_,a) (_,b) -> Pervasives.(=) a b)) = 2 TEST = length (remove_consecutive_duplicates [(0,1);(2,2);(0,2);(4,1)] ~equal:(fun (_,a) (_,b) -> Pervasives.(=) a b)) = 3 (** returns sorted version of list with duplicates removed *) let dedup ?(compare=Pervasives.compare) list = match list with | [] -> [] (* performance hack *) | _ -> let equal x x' = compare x x' = 0 in let sorted = List.sort ~cmp:compare list in remove_consecutive_duplicates ~equal sorted TEST = dedup [] = [] TEST = dedup [5;5;5;5;5] = [5] TEST = length (dedup [2;1;5;3;4]) = 5 TEST = length (dedup [2;3;5;3;4]) = 4 TEST = length (dedup [(0,1);(2,2);(0,2);(4,1)] ~compare:(fun (a,_) (b,_) -> Pervasives.compare a b)) = 3 TEST = length (dedup [(0,1);(2,2);(0,2);(4,1)] ~compare:(fun (_,a) (_,b) -> Pervasives.compare a b)) = 2 let contains_dup ?compare lst = length (dedup ?compare lst) <> length lst let find_a_dup ?(compare=Pervasives.compare) l = let sorted = List.sort ~cmp:compare l in let rec loop l = match l with [] | [_] -> None | hd1 :: hd2 :: tl -> if compare hd1 hd2 = 0 then Some (hd1) else loop (hd2 :: tl) in loop sorted TEST = find_a_dup [] = None TEST = find_a_dup [3] = None TEST = find_a_dup [3;4] = None TEST = find_a_dup [3;3] = Some 3 TEST = find_a_dup [3;5;4;6;12] = None TEST = find_a_dup [3;5;4;5;12] = Some 5 TEST = find_a_dup [3;5;12;5;12] = Some 5 TEST = find_a_dup [(0,1);(2,2);(0,2);(4,1)] = None TEST = (find_a_dup [(0,1);(2,2);(0,2);(4,1)] ~compare:(fun (_,a) (_,b) -> Pervasives.compare a b)) <> None TEST = let dup = find_a_dup [(0,1);(2,2);(0,2);(4,1)] ~compare:(fun (a,_) (b,_) -> Pervasives.compare a b) in match dup with | Some (0, _) -> true | _ -> false type sexp_thunk = unit -> Sexplib.Sexp.t let sexp_of_sexp_thunk x = x () exception Duplicate_found of sexp_thunk * string with sexp let exn_if_dup ?compare ?(context="exn_if_dup") t ~to_sexp = match find_a_dup ?compare t with | None -> () | Some dup -> raise (Duplicate_found ((fun () -> to_sexp dup),context)) let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t ~cmp = Container.min_elt ~fold t ~cmp let max_elt t ~cmp = Container.max_elt ~fold t ~cmp let init n ~f = if n < 0 then invalid_argf "List.init %d" n (); let rec loop i accum = assert (i >= 0); if i = 0 then accum else loop (i-1) (f (i-1) :: accum) in loop n [] ;; let rev_filter_map l ~f = let rec loop l accum = match l with | [] -> accum | hd :: tl -> match f hd with | Some x -> loop tl (x :: accum) | None -> loop tl accum in loop l [] ;; let filter_map l ~f = List.rev (rev_filter_map l ~f) TEST = filter_map ~f:(fun x -> Some x) Test_values.l1 = Test_values.l1 TEST = filter_map ~f:(fun x -> Some x) [] = [] TEST = filter_map ~f:(fun _x -> None) [1.;2.;3.] = [] TEST = filter_map ~f:(fun x -> if (x > 0) then Some x else None) [1;-1;3] = [1;3] let rev_filter_mapi l ~f = let rec loop i l accum = match l with | [] -> accum | hd :: tl -> match f i hd with | Some x -> loop (i + 1) tl (x :: accum) | None -> loop (i + 1) tl accum in loop 0 l [] ;; let filter_mapi l ~f = List.rev (rev_filter_mapi l ~f) TEST = filter_mapi ~f:(fun _i x -> Some x) Test_values.l1 = Test_values.l1 TEST = filter_mapi ~f:(fun _i x -> Some x) [] = [] TEST = filter_mapi ~f:(fun _i _x -> None) [1.;2.;3.] = [] TEST = filter_mapi ~f:(fun _i x -> if (x > 0) then Some x else None) [1;-1;3] = [1;3] TEST = filter_mapi ~f:(fun i x -> if (i mod 2=0) then Some x else None) [1;-1;3] = [1;3] let filter_opt l = filter_map l ~f:(fun x -> x) let partition_map t ~f = let rec loop t fst snd = match t with | [] -> (rev fst, rev snd) | x :: t -> match f x with | `Fst y -> loop t (y :: fst) snd | `Snd y -> loop t fst (y :: snd) in loop t [] [] ;; let partition_tf t ~f = let f x = if f x then `Fst x else `Snd x in partition_map t ~f ;; module Assoc = struct type ('a, 'b) t = ('a * 'b) list with bin_io, sexp, compare let find t ?(equal=Poly.equal) key = match find t ~f:(fun (key', _) -> equal key key') with | None -> None | Some x -> Some (snd x) let find_exn t ?(equal=Poly.equal) key = match find t key ~equal with | None -> raise Not_found | Some value -> value let mem t ?(equal=Poly.equal) key = (find t ~equal key) <> None let remove t ?(equal=Poly.equal) key = filter t ~f:(fun (key', _) -> not (equal key key')) let add t ?(equal=Poly.equal) key value = (* the remove doesn't change the map semantics, but keeps the list small *) (key, value) :: remove t ~equal key let inverse t = map t ~f:(fun (x, y) -> (y, x)) let map t ~f = List.map t ~f:(fun (key, value) -> (key, f value)) end let sub l ~pos ~len = (* We use [pos > length l - len] rather than [pos + len > length l] to avoid the possibility of overflow. *) if pos < 0 || len < 0 || pos > length l - len then invalid_arg "List.sub"; List.rev (foldi l ~init:[] ~f:(fun i acc el -> if i >= pos && i < (pos + len) then el :: acc else acc ) ) ;; let slice a start stop = Ordered_collection_common.slice ~length_fun:length ~sub_fun:sub a start stop let split_n t_orig n = if n <= 0 then ([], t_orig) else let rec loop n t accum = if n = 0 then (List.rev accum, t) else match t with | [] -> (t_orig, []) (* in this case, t_orig = List.rev accum *) | hd :: tl -> loop (n - 1) tl (hd :: accum) in loop n t_orig [] TEST = split_n [1;2;3;4;5;6] 3 = ([1;2;3],[4;5;6]) TEST = split_n [1;2;3;4;5;6] 100 = ([1;2;3;4;5;6],[]) TEST = split_n [1;2;3;4;5;6] 0 = ([],[1;2;3;4;5;6]) TEST = split_n [1;2;3;4;5;6] (-5) = ([],[1;2;3;4;5;6]) let take t n = fst (split_n t n) let drop t n = snd (split_n t n) let split_while xs ~f = let rec loop acc = function | hd :: tl when f hd -> loop (hd :: acc) tl | t -> (rev acc, t) in loop [] xs ;; let take_while t ~f = fst (split_while t ~f) let drop_while t ~f = snd (split_while t ~f) TEST_MODULE "{take,drop,split}_while" = struct let pred = function | '0' .. '9' -> true | _ -> false let test xs prefix suffix = let (prefix1, suffix1) = split_while ~f:pred xs in let prefix2 = take_while xs ~f:pred in let suffix2 = drop_while xs ~f:pred in xs = prefix @ suffix && prefix = prefix1 && prefix = prefix2 && suffix = suffix1 && suffix = suffix2 TEST = test ['1';'2';'3';'a';'b';'c'] ['1';'2';'3'] ['a';'b';'c'] TEST = test ['1';'2'; 'a';'b';'c'] ['1';'2' ] ['a';'b';'c'] TEST = test ['1'; 'a';'b';'c'] ['1' ] ['a';'b';'c'] TEST = test [ 'a';'b';'c'] [ ] ['a';'b';'c'] TEST = test ['1';'2';'3' ] ['1';'2';'3'] [ ] TEST = test [ ] [ ] [ ] end let cartesian_product list1 list2 = if list2 = [] then [] else let rec loop l1 l2 accum = match l1 with | [] -> accum | (hd :: tl) -> loop tl l2 (List.rev_append (map ~f:(fun x -> (hd,x)) l2) accum) in List.rev (loop list1 list2 []) let concat l = fold_right l ~init:[] ~f:append TEST = concat [] = [] TEST = concat [[]] = [] TEST = concat [[3]] = [3] TEST = concat [[1;2;3;4]] = [1;2;3;4] TEST = concat [[1;2;3;4];[5;6;7];[8;9;10];[];[11;12]] = [1;2;3;4;5;6;7;8;9;10;11;12] let concat_no_order l = fold l ~init:[] ~f:(fun acc l -> rev_append l acc) let cons x l = x :: l let is_empty l = match l with [] -> true | _ -> false let is_sorted l ~compare = let rec loop l = match l with | [] | [_] -> true | x1 :: ((x2 :: _) as rest) -> compare x1 x2 <= 0 && loop rest in loop l TEST = is_sorted [] ~compare TEST = is_sorted [1] ~compare TEST = is_sorted [1; 2; 3; 4] ~compare TEST = not (is_sorted [2; 1] ~compare) TEST = not (is_sorted [1; 3; 2] ~compare) let is_sorted_strictly l ~compare = let rec loop l = match l with | [] | [_] -> true | x1 :: ((x2 :: _) as rest) -> compare x1 x2 < 0 && loop rest in loop l ;; TEST_UNIT = List.iter ~f:(fun (t, expect) -> assert (expect = is_sorted_strictly t ~compare)) [ [] , true; [ 1 ] , true; [ 1; 2 ] , true; [ 1; 1 ] , false; [ 2; 1 ] , false; [ 1; 2; 3 ], true; [ 1; 1; 3 ], false; [ 1; 2; 2 ], false; ] ;; module Infix = struct let ( @ ) = append end let permute ?(random_state = Random.State.default) list = match list with (* special cases to speed things up in trivial cases *) | [] | [_] -> list | [ x; y ] -> if Random.State.bool random_state then [ y; x ] else list | _ -> let arr = Array.of_list list in Array_permute.permute arr ~random_state; Array.to_list arr; ;; let to_string ~f t = Sexplib.Sexp.to_string (sexp_of_t (fun x -> Sexplib.Sexp.Atom x) (List.map t ~f)) ;; let compare cmp a b = let rec loop a b = match a, b with | [], [] -> 0 | [], _ -> -1 | _ , [] -> 1 | x :: xs, y :: ys -> let n = cmp x y in if n = 0 then loop xs ys else n in loop a b ;; let equal t1 t2 ~equal = let rec loop t1 t2 = match t1, t2 with | [], [] -> true | x1 :: t1, x2 :: t2 -> equal x1 x2 && loop t1 t2 | _ -> false in loop t1 t2 ;; let transpose = let rec transpose_aux t rev_columns = match partition_map t ~f:(function [] -> `Snd () | x :: xs -> `Fst (x, xs)) with | (_ :: _, _ :: _) -> None | ([], _) -> Some (rev_append rev_columns []) | (heads_and_tails, []) -> let (column, trimmed_rows) = unzip heads_and_tails in transpose_aux trimmed_rows (column :: rev_columns) in fun t -> transpose_aux t [] exception Transpose_got_lists_of_different_lengths of int list with sexp let transpose_exn l = match transpose l with | Some l -> l | None -> raise (Transpose_got_lists_of_different_lengths (List.map l ~f:List.length)) TEST_MODULE "transpose" = struct let round_trip a b = transpose a = Some b && transpose b = Some a TEST = round_trip [] [] TEST = transpose [[]] = Some [] TEST = transpose [[]; []] = Some [] TEST = transpose [[]; []; []] = Some [] TEST = round_trip [[1]] [[1]] TEST = round_trip [[1]; [2]] [[1; 2]] TEST = round_trip [[1]; [2]; [3]] [[1; 2; 3]] TEST = round_trip [[1; 2]; [3; 4]] [[1; 3]; [2; 4]] TEST = round_trip [[1; 2; 3]; [4; 5; 6]] [[1; 4]; [2; 5]; [3; 6]] TEST = transpose [[]; [1]] = None TEST = transpose [[1;2];[3]] = None end let intersperse t ~sep = match t with | [] -> [] | x :: xs -> x :: fold_right xs ~init:[] ~f:(fun y acc -> sep :: y :: acc) TEST = intersperse [1;2;3] ~sep:0 = [1;0;2;0;3] TEST = intersperse [1;2] ~sep:0 = [1;0;2] TEST = intersperse [1] ~sep:0 = [1] TEST = intersperse [] ~sep:0 = [] core_kernel-113.00.00/src/core_list.mli000066400000000000000000000415221256461164500175770ustar00rootroot00000000000000(** Tail recursive version of standard List functions, plus additional operations. *) (** [compare] on lists is lexicographic. *) type 'a t = 'a list with bin_io, compare, sexp, typerep include Container.S1 with type 'a t := 'a t include Monad.S with type 'a t := 'a t (** [of_list] is the identity function. It is useful so that the [List] module matches the same signature that other container modules do, namely: {[ val of_list : 'a List.t -> 'a t ]} *) val of_list : 'a t -> 'a t val nth : 'a t -> int -> 'a option (** Return the [n]-th element of the given list. The first element (head of the list) is at position 0. Raise if the list is too short or [n] is negative. *) val nth_exn : 'a t -> int -> 'a (** List reversal. *) val rev : 'a t -> 'a t (** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. This is equivalent to [(]{!List.rev}[ l1) @ l2], but [rev_append] is more efficient. *) val rev_append : 'a t -> 'a t -> 'a t (** [List.unordered_append l1 l2] has the same elements as [l1 @ l2], but in some unspecified order. Generally takes time proportional to length of first list, but is O(1) if either list is empty. *) val unordered_append : 'a t -> 'a t -> 'a t (** [List.rev_map l ~f] gives the same result as {!List.rev}[ (]{!ListLabels.map}[ f l)], but is more efficient. *) val rev_map : 'a t -> f:('a -> 'b) -> 'b t (** [fold_left] is the same as [fold], and one should always use [fold] rather than [fold_left], except in functors that are parameterized over a more general signature where this equivalence does not hold. *) val fold_left : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b (** [List.iter2_exn [a1; ...; an] [b1; ...; bn] ~f] calls in turn [f a1 b1; ...; f an bn]. Raise if the two lists have different lengths. *) val iter2_exn : 'a t -> 'b t -> f:('a -> 'b -> unit) -> unit (** [List.rev_map2_exn l1 l2 ~f] gives the same result as [List.rev (List.map2_exn l1 l2 ~f)], but is more efficient. *) val rev_map2_exn: 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t (** [List.fold2_exn ~f ~init:a [b1; ...; bn] [c1; ...; cn]] is [f (... (f (f a b1 c1) b2 c2) ...) bn cn]. Raise if the two lists have different lengths. *) val fold2_exn : 'a t -> 'b t -> init:'c -> f:('c -> 'a -> 'b -> 'c) -> 'c (** Same as {!List.for_all}, but for a two-argument predicate. Raise if the two lists have different lengths. *) val for_all2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool (** Same as {!List.exists}, but for a two-argument predicate. Raise if the end of one list is reached before the end of the other. *) val exists2_exn : 'a t -> 'b t -> f:('a -> 'b -> bool) -> bool (** [filter l ~f] returns all the elements of the list [l] that satisfy the predicate [p]. The order of the elements in the input list is preserved. *) val filter : 'a t -> f:('a -> bool) -> 'a t (** Like [filter], but reverses the order of the input list *) val rev_filter : 'a t -> f:('a -> bool) -> 'a t val filteri : 'a t -> f: (int -> 'a -> bool) -> 'a t (** [partition_map t ~f] partitions [t] according to [f]. *) val partition_map : 'a t -> f:('a -> [ `Fst of 'b | `Snd of 'c ]) -> 'b t * 'c t (** [partition_tf l ~f] returns a pair of lists [(l1, l2)], where [l1] is the list of all the elements of [l] that satisfy the predicate [p], and [l2] is the list of all the elements of [l] that do not satisfy [p]. The order of the elements in the input list is preserved. The "tf" suffix is mnemonic to remind readers at a call that the result is (trues, falses). *) val partition_tf : 'a t -> f:('a -> bool) -> 'a t * 'a t (** [split_n n \[e1; ...; em\]] is [(\[e1; ...; en\], \[en+1; ...; em\])]. If [n > m], [(\[e1; ...; em\], \[\])] is returned. If [n < 0], [(\[\], \[e1; ...; em\])] is returned. *) val split_n : 'a t -> int -> 'a t * 'a t (** Sort a list in increasing order according to a comparison function. The comparison function must return 0 if its arguments compare as equal, a positive integer if the first is greater, and a negative integer if the first is smaller (see Array.sort for a complete specification). For example, {!Pervasives.compare} is a suitable comparison function. The current implementation uses Merge Sort. It runs in linear heap space and logarithmic stack space. Presently, the sort is stable, meaning that two equal elements in the input will be in the same order in the output. *) val sort : cmp:('a -> 'a -> int) -> 'a t -> 'a t (** Same as sort, but guaranteed to be stable *) val stable_sort : cmp:('a -> 'a -> int) -> 'a t -> 'a t (** Merge two lists: assuming that [l1] and [l2] are sorted according to the comparison function [cmp], [merge cmp l1 l2] will return a sorted list containing all the elements of [l1] and [l2]. If several elements compare equal, the elements of [l1] will be before the elements of [l2]. *) val merge : 'a t -> 'a t -> cmp:('a -> 'a -> int) -> 'a t val hd : 'a t -> 'a option val tl : 'a t -> 'a t option (** Return the first element of the given list. Raise if the list is empty. *) val hd_exn : 'a t -> 'a (** Return the given list without its first element. Raise if the list is empty. *) val tl_exn : 'a t -> 'a t val findi : 'a t -> f:(int -> 'a -> bool) -> (int * 'a) option (** [find_exn t ~f] returns the first element of [t] that satisfies [f]. It raises [Not_found] if there is no such element. *) val find_exn : 'a t -> f:('a -> bool) -> 'a (** {6 Tail-recursive implementations of standard List operations} *) (** E.g. [append [1; 2] [3; 4; 5]] is [[1; 2; 3; 4; 5]] *) val append : 'a t -> 'a t -> 'a t (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]. *) val map : 'a t -> f:('a -> 'b) -> 'b t (** [concat_map t ~f] is [concat (map t ~f)], except that there is no guarantee about the order in which [f] is applied to the elements of [t]. *) val concat_map : 'a t -> f:('a -> 'b t) -> 'b t (** [concat_mapi t ~f] is like concat_map, but passes the index as an argument *) val concat_mapi : 'a t -> f:(int -> 'a -> 'b t) -> 'b t (** [List.map2_exn [a1; ...; an] [b1; ...; bn] ~f] is [[f a1 b1; ...; f an bn]]. Raise if the two lists have different lengths. *) val map2_exn :'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t val rev_map3_exn : 'a t -> 'b t -> 'c t -> f:('a -> 'b -> 'c -> 'd) -> 'd t val map3_exn : 'a t -> 'b t -> 'c t -> f:('a -> 'b -> 'c -> 'd) -> 'd t (** [rev_map_append l1 l2 ~f] reverses [l1] mapping [f] over each element, and appends the result to the front of [l2]. *) val rev_map_append : 'a t -> 'b t -> f:('a -> 'b) -> 'b t (** [List.fold_right [a1; ...; an] ~f ~init:b] is [f a1 (f a2 (... (f an b) ...))]. *) val fold_right : 'a t -> f:('a -> 'b -> 'b) -> init:'b -> 'b (** Transform a list of pairs into a pair of lists: [unzip [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. *) val unzip : ('a * 'b) t -> 'a t * 'b t (** Transform a pair of lists into an (optional) list of pairs: [zip [a1; ...; an] [b1; ...; bn]] is [[(a1,b1); ...; (an,bn)]]. Returns None if the two lists have different lengths. *) val zip : 'a t -> 'b t -> ('a * 'b) t option val zip_exn : 'a t -> 'b t -> ('a * 'b) t (** mapi is just like map, but it also passes in the index of each element as the first argument to the mapped function. Tail-recursive. *) val mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t val rev_mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t (** iteri is just like iter, but it also passes in the index of each element as the first argument to the iter'd function. Tail-recursive. *) val iteri : 'a t -> f:(int -> 'a -> unit) -> unit (** foldi is just like fold, but it also passes in the index of each element as the first argument to the folded function. Tail-recursive. *) val foldi : 'a t -> f:(int -> 'b -> 'a -> 'b) -> init:'b -> 'b (** [reduce_exn [a1; ...; an] ~f] is [f (... (f (f a1 a2) a3) ...) an]. It fails on the empty list. Tail recursive. *) val reduce_exn : 'a t -> f:('a -> 'a -> 'a) -> 'a val reduce : 'a t -> f:('a -> 'a -> 'a) -> 'a option (** [reduce_balanced] returns the same value as [reduce] when [f] is associative, but differs in that the tree of nested applications of [f] has logarithmic depth. This is useful when your ['a] grows in size as you reduce it and [f] becomes more expensive with bigger inputs. For example, [reduce_balanced ~f:(^)] takes [n*log(n)] time, while [reduce ~f:(^)] takes quadratic time. *) val reduce_balanced : 'a t -> f:('a -> 'a -> 'a) -> 'a option val reduce_balanced_exn : 'a t -> f:('a -> 'a -> 'a) -> 'a (** [group l ~break] returns a list of lists (i.e., groups) whose concatenation is equal to the original list. Each group is broken where break returns true on a pair of successive elements. Example group ~break:(<>) ['M';'i';'s';'s';'i';'s';'s';'i';'p';'p';'i'] -> [['M'];['i'];['s';'s'];['i'];['s';'s'];['i'];['p';'p'];['i']] *) val group : 'a t -> break:('a -> 'a -> bool) -> 'a t t (** This is just like group, except that you get the index in the original list of the current element along with the two elements. Example, group the chars of Mississippi into triples groupi ~break:(fun i _ _ -> i mod 3 = 0) ['M';'i';'s';'s';'i';'s';'s';'i';'p';'p';'i'] -> [['M'; 'i'; 's']; ['s'; 'i'; 's']; ['s'; 'i'; 'p']; ['p'; 'i']] *) val groupi : 'a t -> break:(int -> 'a -> 'a -> bool) -> 'a t t (** The final element of a list. The _exn version raises on the empty list. *) val last : 'a t -> 'a option val last_exn : 'a t -> 'a (** [is_prefix xs ~prefix] returns [true] if [xs] starts with [prefix]. *) val is_prefix : 'a t -> prefix:'a t -> equal:('a -> 'a -> bool) -> bool (** [find_consecutive_duplicate t ~equal] returns the first pair of consecutive elements [(a1, a2)] in [t] such that [equal a1 a2]. They are returned in the same order as they appear in [t]. *) val find_consecutive_duplicate : 'a t -> equal:('a -> 'a -> bool) -> ('a * 'a) option (** [remove_consecutive_duplicates]. The same list with consecutive duplicates removed. The relative order of the other elements is unaffected. *) val remove_consecutive_duplicates : 'a t -> equal:('a -> 'a -> bool) -> 'a t (** [dedup] (de-duplicate). The same list with duplicates removed, but the order is not guaranteed. *) val dedup : ?compare:('a -> 'a -> int) -> 'a t -> 'a t (** [contains_dup] True if there are any two elements in the list which are the same. *) val contains_dup : ?compare:('a -> 'a -> int) -> 'a t -> bool (** [find_a_dup] returns a duplicate from the list (no guarantees about which duplicate you get), or None if there are no dups. *) val find_a_dup : ?compare:('a -> 'a -> int) -> 'a t -> 'a option (** only raised in [exn_if_dup] below *) exception Duplicate_found of (unit -> Sexplib.Sexp.t) * string (** [exn_if_dup ?compare ?context t ~to_sexp] will run [find_a_dup] on [t], and raise [Duplicate_found] if a duplicate is found. The [context] is the second argument of the exception *) val exn_if_dup : ?compare:('a -> 'a -> int) -> ?context:string -> 'a t -> to_sexp:('a -> Sexplib.Sexp.t) -> unit (** [count l ~f] is the number of elements in [l] that satisfy the predicate [f]. *) val count : 'a t -> f:('a -> bool) -> int (** [range ?stride ?start ?stop start_i stop_i] is the list of integers from [start_i] to [stop_i], stepping by [stride]. If [stride] < 0 then we need [start_i] > [stop_i] for the result to be nonempty (or [start_i] = [stop_i] in the case where both bounds are inclusive). *) val range : ?stride:int (** default = 1 *) -> ?start:[`inclusive|`exclusive] (** default = `inclusive *) -> ?stop:[`inclusive|`exclusive] (** default = `exclusive *) -> int -> int -> int t (** [init n ~f] is [[(f 0); (f 1); ...; (f (n-1))]]. It is an error if [n < 0]. *) val init : int -> f:(int -> 'a) -> 'a t (** [rev_filter_map l ~f] is the reversed sublist of [l] containing only elements for which [f] returns [Some e]. *) val rev_filter_map : 'a t -> f:('a -> 'b option) -> 'b t (** rev_filter_mapi is just like rev_filter_map, but it also passes in the index of each element as the first argument to the mapped function. Tail-recursive. *) val rev_filter_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b t (** [filter_map l ~f] is the sublist of [l] containing only elements for which [f] returns [Some e]. *) val filter_map : 'a t -> f:('a -> 'b option) -> 'b t (** filter_mapi is just like filter_map, but it also passes in the index of each element as the first argument to the mapped function. Tail-recursive. *) val filter_mapi : 'a t -> f:(int -> 'a -> 'b option) -> 'b t (** [filter_opt l] is the sublist of [l] containing only elements which are [Some e]. In other words, [filter_opt l] = [filter_map ~f:ident l]. *) val filter_opt : 'a option t -> 'a t (** Interpret a list of (key, value) pairs as a map in which only the first occurrence of a key affects the semantics, i.e.: {[List.Assoc.xxx alist ...args... ]} is always the same as (or at least sort of isomorphic to): {[ Map.xxx (alist |! Map.of_alist_multi |! Map.map ~f:List.hd) ...args... }] *) module Assoc : sig type ('a, 'b) t = ('a * 'b) list with bin_io, sexp, compare val add : ('a, 'b) t -> ?equal:('a -> 'a -> bool) -> 'a -> 'b -> ('a, 'b) t val find : ('a, 'b) t -> ?equal:('a -> 'a -> bool) -> 'a -> 'b option val find_exn : ('a, 'b) t -> ?equal:('a -> 'a -> bool) -> 'a -> 'b val mem : ('a, 'b) t -> ?equal:('a -> 'a -> bool) -> 'a -> bool val remove : ('a, 'b) t -> ?equal:('a -> 'a -> bool) -> 'a -> ('a, 'b) t val map : ('a, 'b) t -> f:('b -> 'c) -> ('a, 'c) t (** Bijectivity is not guaranteed because we allow a key to appear more than once. *) val inverse : ('a, 'b) t -> ('b, 'a) t end (** Note that [sub], unlike [slice], doesn't use python-style indices! *) (** [sub pos len l] is the [len]-element sublist of [l], starting at [pos]. *) val sub : 'a t -> pos:int -> len:int -> 'a t (** [slice l start stop] returns a new list including elements [l.(start)] through [l.(stop-1)], normalized python-style. *) val slice : 'a t -> int -> int -> 'a t (** [take l n] is [fst (split_n n l)]. [drop l n] is [snd (split_n n l)]. *) val take : 'a t -> int -> 'a t val drop : 'a t -> int -> 'a t (** [take_while l ~f] returns the longest prefix of [l] for which [f] is [true]. *) val take_while : 'a t -> f : ('a -> bool) -> 'a t (** [drop_while l ~f] drops the longest prefix of [l] for which [f] is [true]. *) val drop_while : 'a t -> f : ('a -> bool) -> 'a t (** [split_while xs ~f = (take_while xs ~f, drop_while xs ~f)] *) val split_while : 'a t -> f : ('a -> bool) -> 'a t * 'a t (** Concatenate a list of lists. The elements of the argument are all concatenated together (in the same order) to give the result. Tail recursive over outer and inner lists. *) val concat : 'a t t -> 'a t (** Same as [concat] but faster and without preserving any ordering (ie for lists that are essentially viewed as multi-sets. *) val concat_no_order : 'a t t -> 'a t val cons : 'a -> 'a t -> 'a t (** Returns a list with all possible pairs -- if the input lists have length len1 and len2, the resulting list will have length len1*len2. *) val cartesian_product : 'a t -> 'b t -> ('a * 'b) t val to_string : f:('a -> string) -> 'a t -> string (** [permute ?random_state t] returns a permutation of [t]. [permute] side affects [random_state] by repeated calls to [Random.State.int]. If [random_state] is not supplied, [permute] uses [Random.State.default]. *) val permute : ?random_state:Core_random.State.t -> 'a t -> 'a t (** [is_sorted t ~compare] returns [true] iff forall adjacent [a1; a2] in [t], [compare a1 a2 <= 0]. [is_sorted_strictly] is similar, except it uses [<] instead of [<=]. *) val is_sorted : 'a t -> compare:('a -> 'a -> int) -> bool val is_sorted_strictly : 'a t -> compare:('a -> 'a -> int) -> bool val equal : 'a t -> 'a t -> equal:('a -> 'a -> bool) -> bool module Infix : sig val ( @ ) : 'a t -> 'a t -> 'a t end (** [transpose m] transposes the rows and columns of the matrix [m], considered as either a row of column lists or (dually) a column of row lists. Example, transpose [[1;2;3];[4;5;6]] = [[1;4];[2;5];[3;6]] On non-empty rectangular matrices, [transpose] is an involution (i.e., [transpose (transpose m) = m]). Transpose returns None when called on lists of lists with non-uniform lengths. **) val transpose : 'a t t -> 'a t t option (** [transpose_exn] transposes the rows and columns of its argument, throwing an exception if the list is not rectangular. **) val transpose_exn : 'a t t -> 'a t t (** [intersperse xs ~sep] places [sep] between adjacent elements of [xs]. e.g. [intersperse [1;2;3] ~sep:0 = [1;0;2;0;3]] *) val intersperse : 'a t -> sep:'a -> 'a t core_kernel-113.00.00/src/core_list_unit_tests.ml000066400000000000000000000515661256461164500217200ustar00rootroot00000000000000open Std_internal TEST_MODULE "random" = struct module G = Quickcheck.Generator module O = Quickcheck.Observer module type T = sig type t with sexp_of val t_gen : t G.t val t_obs : t O.t include Comparable.S with type t := t val module_name : string end module type Math = sig type t include T with type t := t include Commutative_group.S with type t := t end module Make (T : T) (Math : Math) = struct open T open G.Monad_infix module Q = Quickcheck.Configure (struct include Quickcheck let default_seed = `Deterministic (sprintf "%s values with %s operators." (String.capitalize T.module_name) (String.capitalize Math.module_name)) end) ;; TEST_UNIT "mem true" = Q.test ~sexp_of:<:sexp_of< t * t list >> (G.list t_gen >>= fun list -> G.of_list list >>| fun elt_of_list -> elt_of_list, list) ~f:(fun (elt_of_list, list) -> <:test_result< bool >> (List.mem list elt_of_list ~equal) ~expect:true) TEST_UNIT "mem false" = Q.test ~sexp_of:<:sexp_of< t * t list >> (G.bind_choice t_gen (fun choice -> let x = G.Choice.value choice in let not_x_gen = G.Choice.updated_gen choice ~keep:`All_choices_except_this_choice in G.list not_x_gen >>| fun list_of_not_x -> x, list_of_not_x)) ~f:(fun (x, list_of_not_x) -> <:test_result< bool >> (List.mem list_of_not_x x ~equal) ~expect:false) TEST_UNIT "len" = Q.test ~sexp_of:<:sexp_of< int * t list >> (G.size >>= fun len -> G.list t_gen ~length:(`Exactly len) >>| fun list -> len, list) ~f:(fun (len, list) -> <:test_result< int >> (List.length list) ~expect:len) TEST_UNIT "is_empty true" = Q.test ~sexp_of:<:sexp_of< t list >> (G.singleton []) ~f:(fun empty -> <:test_result< bool >> (List.is_empty empty) ~expect:true) TEST_UNIT "is_empty false" = Q.test ~sexp_of:<:sexp_of< t list >> (G.tuple2 t_gen (G.list t_gen) >>| fun (x,list) -> x::list) ~f:(fun non_empty -> <:test_result< bool >> (List.is_empty non_empty) ~expect:false) TEST_UNIT "iter" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> let q = Queue.create () in List.iter list ~f:(Queue.enqueue q); <:test_result< t list >> (Queue.to_list q) ~expect:list) TEST_UNIT "sum vs fold" = Q.test ~sexp_of:<:sexp_of< t list * (t -> Math.t) >> (G.tuple2 (G.list t_gen) (G.fn t_obs Math.t_gen)) ~f:(fun (list, f) -> <:test_eq< Math.t >> (List.fold list ~init:Math.zero ~f:(fun m x -> Math.(+) m (f x))) (List.sum (module Math) list ~f)) TEST_UNIT "for_all vs exists" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< bool >> (List.for_all list ~f) (not (List.exists list ~f:(Fn.non f)))) TEST_UNIT "exists vs mem" = Q.test ~sexp_of:<:sexp_of< t * t list >> (G.tuple2 t_gen (G.list t_gen)) ~f:(fun (x, list) -> <:test_eq< bool >> (List.exists list ~f:(fun y -> equal x y)) (List.mem list x ~equal)) TEST_UNIT "exists vs find" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< bool >> (List.exists list ~f) (Option.is_some (List.find list ~f))) TEST_UNIT "count vs length/filter" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< int >> (List.count list ~f) (List.length (List.filter list ~f))) TEST_UNIT "find vs find_map" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< t option >> (List.find list ~f) (List.find_map list ~f:(fun x -> if f x then Some x else None))) TEST_UNIT "to_list" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_result< t list >> (List.to_list list) ~expect:list) TEST_UNIT "to_array + Array.to_list" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_result< t list >> (Array.to_list (List.to_array list)) ~expect:list) TEST_UNIT "max_elt vs min_elt" = Q.test ~sexp_of:<:sexp_of< t list * (t -> t -> int) >> (G.tuple2 (G.list t_gen) (G.compare_fn t_obs)) ~f:(fun (list, cmp) -> <:test_eq< t option >> (List.min_elt list ~cmp) (List.max_elt list ~cmp:(fun x y -> cmp y x))) TEST_UNIT "return" = Q.test ~sexp_of:<:sexp_of< t >> t_gen ~f:(fun x -> <:test_result< t list >> (List.return x) ~expect:[x]) TEST_UNIT "map vs bind" = Q.test ~sexp_of:<:sexp_of< t list * (t -> t) >> (G.tuple2 (G.list t_gen) (G.fn t_obs t_gen)) ~f:(fun (list, f) -> <:test_eq< t list >> (List.map list ~f) (List.bind list (fun x -> [ f x ]))) TEST_UNIT "monad left identity" = Q.test ~sexp_of:<:sexp_of< t * (t -> t list) >> (G.tuple2 t_gen (G.fn t_obs (G.list t_gen))) ~f:(fun (x, f) -> <:test_eq< t list >> (List.bind (List.return x) f) (f x)) TEST_UNIT "monad right identity" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_result< t list >> (List.bind list List.return) ~expect:list) TEST_UNIT "monad associativity" = Q.test ~sexp_of:<:sexp_of< t list * (t -> t list) * (t -> t list) >> (G.tuple3 (G.list t_gen) (G.fn t_obs (G.list t_gen)) (G.fn t_obs (G.list t_gen))) ~f:(fun (list, f, g) -> <:test_eq< t list >> (List.bind (List.bind list f) g) (List.bind list (fun x -> List.bind (f x) g))) TEST_UNIT "join" = Q.test ~sexp_of:<:sexp_of< t list list >> (G.list (G.list t_gen)) ~f:(fun list -> <:test_eq< t list >> (List.join list) (List.bind list Fn.id)) TEST_UNIT "ignore" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_eq< unit list >> (List.ignore_m list) (List.map list ~f:ignore)) TEST_UNIT "of_list + to_list" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_result< t list >> (List.of_list list) ~expect:list) TEST_UNIT "nth vs nth_exn" = Q.test ~sexp_of:<:sexp_of< int * t list >> (G.tuple2 G.size (G.list t_gen)) ~f:(fun (i, list) -> <:test_eq< t option >> (List.nth list i) (Option.try_with (fun () -> List.nth_exn list i))) TEST_UNIT "init + nth_exn" = Q.test ~sexp_of:<:sexp_of< int * int * (int -> t) >> (G.size >>= fun size -> G.tuple3 (G.return size) (G.int_between ~lower_bound:(Incl 0) ~upper_bound:(Excl size)) (G.fn O.int t_gen)) ~f:(fun (size, i, f) -> <:test_result< t >> (List.nth_exn (List.init size ~f) i) ~expect:(f i)) TEST_UNIT "rev^2" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_result< t list >> (List.rev (List.rev list)) ~expect:list) TEST_UNIT "rev_append vs rev + append" = Q.test ~sexp_of:<:sexp_of< t list * t list >> (G.tuple2 (G.list t_gen) (G.list t_gen)) ~f:(fun (list1, list2) -> <:test_eq< t list >> (List.rev_append list1 list2) (List.append (List.rev list1) list2)) TEST_UNIT "unordered_append vs append" = Q.test ~sexp_of:<:sexp_of< t list * t list * t >> (G.tuple3 (G.list t_gen) (G.list t_gen) t_gen) ~f:(fun (list1, list2, x) -> <:test_eq< bool >> (List.mem (List.append list1 list2) x ~equal) (List.mem (List.unordered_append list1 list2) x ~equal)) TEST_UNIT "rev_map vs map + rev" = Q.test ~sexp_of:<:sexp_of< t list * (t -> t) >> (G.tuple2 (G.list t_gen) (G.fn t_obs t_gen)) ~f:(fun (list, f) -> <:test_eq< t list >> (List.rev_map list ~f) (List.rev (List.map list ~f))) TEST_UNIT "fold vs fold_left" = Q.test ~sexp_of:<:sexp_of< t list * t * (t -> t -> t) >> (G.tuple3 (G.list t_gen) t_gen (G.fn2 t_obs t_obs t_gen)) ~f:(fun (list, init, f) -> <:test_eq< t >> (List.fold list ~init ~f) (List.fold_left list ~init ~f)) TEST_UNIT "unzip + iter2_exn vs iter" = Q.test ~sexp_of:<:sexp_of< (t * t) list * (t -> t -> t) >> (G.tuple2 (G.list (G.tuple2 t_gen t_gen)) (G.fn2 t_obs t_obs t_gen)) ~f:(fun (pair_list, f) -> <:test_eq< t list >> (let q = Queue.create () in let list1, list2 = List.unzip pair_list in List.iter2_exn list1 list2 ~f:(fun x y -> Queue.enqueue q (f x y)); Queue.to_list q) (let q = Queue.create () in List.iter pair_list ~f:(fun (x,y) -> Queue.enqueue q (f x y)); Queue.to_list q)) TEST_UNIT "rev_map2_exn vs rev + map2_exn" = Q.test ~sexp_of:<:sexp_of< (t * t) list * (t -> t -> t) >> (G.tuple2 (G.list (G.tuple2 t_gen t_gen)) (G.fn2 t_obs t_obs t_gen)) ~f:(fun (pair_list, f) -> let list1, list2 = List.unzip pair_list in <:test_eq< t list >> (List.rev_map2_exn list1 list2 ~f) (List.rev (List.map2_exn list1 list2 ~f))) TEST_UNIT "unzip + fold2_exn + fold" = Q.test ~sexp_of:<:sexp_of< (t * t) list * t * (t -> t -> t -> t) >> (G.tuple3 (G.list (G.tuple2 t_gen t_gen)) t_gen (G.fn3 t_obs t_obs t_obs t_gen)) ~f:(fun (pair_list, init, f) -> let list1, list2 = List.unzip pair_list in <:test_eq< t >> (List.fold2_exn list1 list2 ~init ~f) (List.fold (List.zip_exn list1 list2) ~init ~f:(fun acc (x,y) -> f acc x y))) TEST_UNIT "unzip + for_all2_exn vs for_all" = Q.test ~sexp_of:<:sexp_of< (t * t) list * (t -> t -> bool) >> (G.tuple2 (G.list (G.tuple2 t_gen t_gen)) (G.fn2 t_obs t_obs G.bool)) ~f:(fun (pair_list, f) -> <:test_eq< bool >> (let list1, list2 = List.unzip pair_list in List.for_all2_exn list1 list2 ~f) (List.for_all pair_list ~f:(fun (x,y) -> f x y))) TEST_UNIT "unzip + exists2_exn vs exists" = Q.test ~sexp_of:<:sexp_of< (t * t) list * (t -> t -> bool) >> (G.tuple2 (G.list (G.tuple2 t_gen t_gen)) (G.fn2 t_obs t_obs G.bool)) ~f:(fun (pair_list, f) -> <:test_eq< bool >> (let list1, list2 = List.unzip pair_list in List.exists2_exn list1 list2 ~f) (List.exists pair_list ~f:(fun (x,y) -> f x y))) TEST_UNIT "filter vs for_all" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_result< bool >> (List.for_all ~f (List.filter ~f list)) ~expect:true) TEST_UNIT "filter true" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_result< t list >> (List.filter list ~f:(const true)) ~expect:list) TEST_UNIT "filter vs rev_filter" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< t list >> (List.rev (List.filter list ~f)) (List.rev_filter list ~f)) TEST_UNIT "filteri vs filter" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< t list >> (List.filter list ~f) (List.filteri list ~f:(fun _ x -> f x))) TEST_UNIT "partition_map vs filter_map" = let partition_of_variant = function | `A a -> `Fst a | `B b -> `Snd b in Q.test ~sexp_of:<:sexp_of< t list * (t -> [ `Fst of t | `Snd of t ]) >> (G.tuple2 (G.list t_gen) (G.fn t_obs (G.variant2 t_gen t_gen >>| partition_of_variant))) ~f:(fun (list, f) -> <:test_eq< t list * t list >> (List.partition_map list ~f) (List.filter_map list ~f:(fun x -> match f x with | `Fst x -> Some x | `Snd _ -> None), List.filter_map list ~f:(fun x -> match f x with | `Fst _ -> None | `Snd x -> Some x))) TEST_UNIT "partition_tf vs partition_map" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< t list * t list >> (List.partition_tf list ~f) (List.partition_map list ~f:(fun x -> if f x then `Fst x else `Snd x))) TEST_UNIT "append + split_n" = Q.test ~sexp_of:<:sexp_of< t list * t list >> (G.tuple2 (G.list t_gen) (G.list t_gen)) ~f:(fun (list1, list2) -> <:test_result< t list * t list >> (List.split_n (List.append list1 list2) (List.length list1)) ~expect:(list1, list2)) TEST_UNIT "sort vs stable_sort" = Q.test ~sexp_of:<:sexp_of< t list * (t -> t -> int) >> (G.tuple2 (G.list t_gen) (G.compare_fn t_obs)) ~f:(fun (list, cmp) -> (* When comparing [t] using [cmp], [sort] and [stable_sort] should be indistinguishable. *) let compare = cmp in <:test_eq< t list >> (List.sort list ~cmp) (List.stable_sort list ~cmp)) TEST_UNIT "stable_sort + merge vs append + stable_sort" = Q.test ~sexp_of:<:sexp_of< t list * t list * (t -> t -> int) >> (G.tuple3 (G.list t_gen) (G.list t_gen) (G.compare_fn t_obs)) ~f:(fun (list1, list2, cmp) -> <:test_eq< t list >> (List.merge ~cmp (List.stable_sort ~cmp list1) (List.stable_sort ~cmp list2)) (List.stable_sort ~cmp (List.append list1 list2))) TEST_UNIT "hd vs hd_exn" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_eq< t option >> (List.hd list) (Option.try_with (fun () -> List.hd_exn list))) TEST_UNIT "tl vs tl_exn" = Q.test ~sexp_of:<:sexp_of< t list >> (G.list t_gen) ~f:(fun list -> <:test_eq< t list option >> (List.tl list) (Option.try_with (fun () -> List.tl_exn list))) TEST_UNIT "find vs find_exn" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< t option >> (List.find list ~f) (Option.try_with (fun () -> List.find_exn list ~f))) TEST_UNIT "find vs findi" = Q.test ~sexp_of:<:sexp_of< t list * (t -> bool) >> (G.tuple2 (G.list t_gen) (G.fn t_obs G.bool)) ~f:(fun (list, f) -> <:test_eq< t option >> (List.find list ~f) (Option.map ~f:snd (List.findi list ~f:(fun _ x -> f x)))) TEST_UNIT "append + rev" = Q.test ~sexp_of:<:sexp_of< t list * t list >> (G.tuple2 (G.list t_gen) (G.list t_gen)) ~f:(fun (list1, list2) -> <:test_eq< t list >> (List.rev (List.append list1 list2)) (List.append (List.rev list2) (List.rev list1))) TEST_UNIT "append associativity" = Q.test ~sexp_of:<:sexp_of< t list * t list * t list >> (G.tuple3 (G.list t_gen) (G.list t_gen) (G.list t_gen)) ~f:(fun (list1, list2, list3) -> <:test_eq< t list >> (List.append list1 (List.append list2 list3)) (List.append (List.append list1 list2) list3)) TEST_UNIT "map + rev vs rev + map" = Q.test ~sexp_of:<:sexp_of< t list * (t -> t) >> (G.tuple2 (G.list t_gen) (G.fn t_obs t_gen)) ~f:(fun (list, f) -> <:test_eq< t list >> (List.rev (List.map list ~f)) (List.map (List.rev list) ~f)) TEST_UNIT "map + append vs append + map" = Q.test ~sexp_of:<:sexp_of< t list * t list * (t -> t) >> (G.tuple3 (G.list t_gen) (G.list t_gen) (G.fn t_obs t_gen)) ~f:(fun (list1, list2, f) -> <:test_eq< t list >> (List.append (List.map list1 ~f) (List.map list2 ~f)) (List.map (List.append list1 list2) ~f)) TEST_UNIT "map vs concat_map" = Q.test ~sexp_of:<:sexp_of< t list * (t -> t) >> (G.tuple2 (G.list t_gen) (G.fn t_obs t_gen)) ~f:(fun (list, f) -> <:test_eq< t list >> (List.map list ~f) (List.concat_map list ~f:(fun x -> [ f x ]))) TEST_UNIT "concat_mapi vs concat_map" = Q.test ~sexp_of:<:sexp_of< t list * (t -> t list) >> (G.tuple2 (G.list t_gen) (G.fn t_obs (G.list t_gen))) ~f:(fun (list, f) -> <:test_eq< t list >> (List.concat_map list ~f) (List.concat_mapi list ~f:(fun _ x -> f x))) TEST_UNIT "unzip + map2_exn vs map" = Q.test ~sexp_of:<:sexp_of< (t * t) list * (t -> t -> t) >> (G.tuple2 (G.list (G.tuple2 t_gen t_gen)) (G.fn2 t_obs t_obs t_gen)) ~f:(fun (pair_list, f) -> <:test_eq< t list >> (let list1, list2 = List.unzip pair_list in List.map2_exn list1 list2 ~f) (List.map pair_list ~f:(fun (x,y) -> f x y))) TEST_UNIT "unzip + map3_exn vs map" = Q.test ~sexp_of:<:sexp_of< (t * (t * t)) list * (t -> t -> t -> t) >> (G.tuple2 (G.list (G.tuple2 t_gen (G.tuple2 t_gen t_gen))) (G.fn3 t_obs t_obs t_obs t_gen)) ~f:(fun (triple_list, f) -> <:test_eq< t list >> (let list1, pair_list = List.unzip triple_list in let list2, list3 = List.unzip pair_list in List.map3_exn list1 list2 list3 ~f) (List.map triple_list ~f:(fun (x,(y,z)) -> f x y z))) TEST_UNIT "rev + map3_exn vs rev_map3_exn" = Q.test ~sexp_of:<:sexp_of< (t * (t * t)) list * (t -> t -> t -> t) >> (G.tuple2 (G.list (G.tuple2 t_gen (G.tuple2 t_gen t_gen))) (G.fn3 t_obs t_obs t_obs t_gen)) ~f:(fun (triple_list, f) -> let list1, pair_list = List.unzip triple_list in let list2, list3 = List.unzip pair_list in <:test_eq< t list >> (List.rev_map3_exn list1 list2 list3 ~f) (List.rev (List.map3_exn list1 list2 list3 ~f))) end (* Float with bitwise comparison. *) module Float_ = struct include Float let compare x y = Int64.compare (Int64.bits_of_float x) (Int64.bits_of_float y) let equal x y = Int64.equal (Int64.bits_of_float x) (Int64.bits_of_float y) end TEST = Float_.equal Float.nan Float.nan module Unit' = struct let t_gen = G.unit let t_obs = O.unit include Unit let module_name = "Unit" end module Bool' = struct let t_gen = G.bool let t_obs = O.bool include Bool let module_name = "Bool" end module Int' = struct let t_gen = G.int let t_obs = O.int include Int let module_name = "Int" end module Float' = struct let t_gen = G.float let t_obs = O.float include Float_ let module_name = "Float" end module String' = struct let t_gen = G.string let t_obs = O.string include String let module_name = "String" end module Char' = struct let t_gen = G.char let t_obs = O.char include Char let module_name = "Char" end module Sexp' = struct let t_gen = G.sexp let t_obs = O.sexp include Sexp let module_name = "Sexp" end TEST_MODULE "unit w/ int" = Make (Unit') (Int') TEST_MODULE "bool w/ float" = Make (Bool') (Float') TEST_MODULE "string w/ int" = Make (String') (Int') TEST_MODULE "char w/ float" = Make (Char') (Float') TEST_MODULE "sexp w/ int" = Make (Sexp') (Int') end core_kernel-113.00.00/src/core_map.ml000066400000000000000000001336701256461164500172360ustar00rootroot00000000000000open Sexplib open Sexplib.Conv open Core_map_intf open With_return module List = Core_list open Int_replace_polymorphic_compare module Tree0 = struct type ('k, 'v) t = | Empty | Leaf of 'k * 'v | Node of ('k, 'v) t * 'k * 'v * ('k, 'v) t * int type ('k, 'v) tree = ('k, 'v) t let height = function | Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,_,h) -> h ;; let invariants t ~compare_key = let rec loop lower upper t = let in_range k = (match lower with | None -> true | Some lower -> compare_key lower k < 0 ) && (match upper with | None -> true | Some upper -> compare_key k upper < 0 ) in match t with | Empty -> true | Leaf (k, _) -> in_range k | Node (l, k, _, r, h) -> let hl = height l and hr = height r in abs (hl - hr) <= 2 && h = (max hl hr) + 1 && in_range k && loop lower (Some k) l && loop (Some k) upper r in loop None None t ;; let create l x d r = let hl = height l and hr = height r in if hl = 0 && hr = 0 then Leaf (x, d) else Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) ;; let singleton key data = Leaf (key, data) let of_sorted_array_unchecked array ~compare_key = let array_length = Array.length array in let arr = if array_length < 2 || let k0, _ = array.(0) in let k1, _ = array.(1) in compare_key k0 k1 < 0 then (fun i -> array.(i)) else (fun i -> array.(array_length - 1 - i)) in let leaf (k, v) = Leaf (k, v) in let rec loop i j = match j - i with | x when x < 0 -> assert false | 0 -> Empty | 1 -> leaf (arr i) | 2 -> let k, v = arr (i + 1) in Node (leaf (arr i), k, v, Empty, 2) | 3 -> let k, v = arr (i + 1) in Node (leaf (arr i), k, v, leaf (arr (i + 2)), 2) | n -> let left_length = n / 2 in let left_i, left_j = i, i + left_length in let right_i, right_j = i + left_length + 1, j in let k, v = arr (i + left_length) in create (loop left_i left_j) k v (loop right_i right_j) in (loop 0 array_length, array_length) ;; let of_sorted_array array ~compare_key = match array with | [||] | [|_|] -> Result.Ok (of_sorted_array_unchecked array ~compare_key) | _ -> with_return (fun r -> let increasing = match compare_key (fst array.(0)) (fst array.(1)) with | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> i < 0 in for i = 1 to Array.length array - 2 do match compare_key (fst array.(i)) (fst array.(i+1)) with | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> if Pervasives.(<>) (i < 0) increasing then r.return (Or_error.error_string "of_sorted_array: elements are not ordered") done; Result.Ok (of_sorted_array_unchecked array ~compare_key) ) let bal l x d r = let hl = height l in let hr = height r in if hl > hr + 2 then begin match l with Empty -> invalid_arg "Map.bal" | Leaf _ -> assert false (* height(Leaf) = 1 && 1 is not larger than hr + 2 *) | Node(ll, lv, ld, lr, _) -> if height ll >= height lr then create ll lv ld (create lr x d r) else begin match lr with Empty -> invalid_arg "Map.bal" | Leaf (lrv, lrd) -> create (create ll lv ld Empty) lrv lrd (create Empty x d r) | Node(lrl, lrv, lrd, lrr, _)-> create (create ll lv ld lrl) lrv lrd (create lrr x d r) end end else if hr > hl + 2 then begin match r with Empty -> invalid_arg "Map.bal" | Leaf _ -> assert false (* height(Leaf) = 1 && 1 is not larger than hl + 2 *) | Node(rl, rv, rd, rr, _) -> if height rr >= height rl then create (create l x d rl) rv rd rr else begin match rl with Empty -> invalid_arg "Map.bal" | Leaf (rlv, rld) -> create (create l x d Empty) rlv rld (create Empty rv rd rr) | Node(rll, rlv, rld, rlr, _) -> create (create l x d rll) rlv rld (create rlr rv rd rr) end end else create l x d r ;; let empty = Empty let is_empty = function Empty -> true | _ -> false let rec add t ~length ~key:x ~data ~compare_key = match t with | Empty -> (Leaf (x, data), length + 1) | Leaf(v, d) -> let c = compare_key x v in if c = 0 then (Leaf(x, data), length) else if c < 0 then (Node(Leaf(x, data), v, d, Empty, 2), length + 1) else (Node(Empty, v, d, Leaf(x, data), 2), length + 1) | Node(l, v, d, r, h) -> let c = compare_key x v in if c = 0 then (Node(l, x, data, r, h), length) else if c < 0 then let l, length = add ~length ~key:x ~data l ~compare_key in (bal l v d r, length) else let r, length = add ~length ~key:x ~data r ~compare_key in (bal l v d r, length) ;; let add' t key data ~compare_key = fst (add t ~length:0 ~key ~data ~compare_key) (* Like [bal] but allows any difference in height between [l] and [r]. *) let rec join l k d r ~compare_key = match l, r with | Empty, _ -> add' r k d ~compare_key | _, Empty -> add' l k d ~compare_key | Leaf(lk, ld), _ -> add' (add' r k d ~compare_key) lk ld ~compare_key | _, Leaf(rk, rd) -> add' (add' l k d ~compare_key) rk rd ~compare_key | Node(ll, lk, ld, lr, lh), Node(rl, rk, rd, rr, rh) -> if lh > rh + 2 (* height lr <= height (join lr k d r) <= height lr + 1 *) then bal ll lk ld (join lr k d r ~compare_key) else if rh > lh + 2 then bal (join l k d rl ~compare_key) rk rd rr else create l k d r ;; let rec split t x ~compare_key = match t with | Empty -> (Empty, None, Empty) | Leaf(k, d) -> let cmp = compare_key x k in if cmp = 0 then (Empty, Some (k, d), Empty) else if cmp < 0 then (Empty, None, t) else (t, None, Empty) | Node(l, k, d, r, _) -> let cmp = compare_key x k in if cmp = 0 then (l, Some (k, d), r) else if cmp < 0 then let ll, maybe, lr = split l x ~compare_key in (ll, maybe, join lr k d r ~compare_key) else let rl, maybe, rr = split r x ~compare_key in (join l k d rl ~compare_key, maybe, rr) ;; let rec find t x ~compare_key = match t with | Empty -> None | Leaf (v, d) -> if compare_key x v = 0 then Some d else None | Node(l, v, d, r, _) -> let c = compare_key x v in if c = 0 then Some d else find (if c < 0 then l else r) x ~compare_key ;; let add_multi t ~length ~key ~data ~compare_key = let data = data :: Option.value (find t key ~compare_key) ~default:[] in add ~length ~key ~data t ~compare_key ;; let find_exn t x ~compare_key = match find t x ~compare_key with | Some data -> data | None -> raise Not_found ;; let mem t x ~compare_key = Option.is_some (find t x ~compare_key) let rec min_elt = function | Empty -> None | Leaf (k, d) -> Some (k, d) | Node (Empty, k, d, _, _) -> Some (k, d) | Node (l, _, _, _, _) -> min_elt l ;; exception Map_min_elt_exn_of_empty_map with sexp exception Map_max_elt_exn_of_empty_map with sexp let min_elt_exn t = match min_elt t with | None -> raise Map_min_elt_exn_of_empty_map | Some v -> v ;; let rec max_elt = function | Empty -> None | Leaf (k, d) -> Some (k, d) | Node (_, k, d, Empty, _) -> Some (k, d) | Node (_, _, _, r, _) -> max_elt r ;; let max_elt_exn t = match max_elt t with | None -> raise Map_max_elt_exn_of_empty_map | Some v -> v ;; let rec remove_min_elt t = match t with Empty -> invalid_arg "Map.remove_min_elt" | Leaf _ -> Empty | Node(Empty, _, _, r, _) -> r | Node(l, x, d, r, _) -> bal (remove_min_elt l) x d r (* assumes that min <= max in the ordering given by compare_key *) let rec fold_range_inclusive t ~min ~max ~init ~f ~compare_key = match t with | Empty -> init | Leaf (k, d) -> if compare_key k min < 0 || compare_key k max > 0 then (* k < min || k > max *) init else f ~key:k ~data:d init | Node (l, k, d, r, _) -> let c_min = compare_key k min in if c_min < 0 then (* if k < min, then this node and its left branch are outside our range *) fold_range_inclusive r ~min ~max ~init ~f ~compare_key else if c_min = 0 then (* if k = min, then this node's left branch is outside our range *) fold_range_inclusive r ~min ~max ~init:(f ~key:k ~data:d init) ~f ~compare_key else (* k > min *) begin let z = fold_range_inclusive l ~min ~max ~init ~f ~compare_key in let c_max = compare_key k max in (* if k > max, we're done *) if c_max > 0 then z else let z = f ~key:k ~data:d z in (* if k = max, then we fold in this one last value and we're done *) if c_max = 0 then z else fold_range_inclusive r ~min ~max ~init:z ~f ~compare_key end ;; let range_to_alist t ~min ~max ~compare_key = List.rev (fold_range_inclusive t ~min ~max ~init:[] ~f:(fun ~key ~data l -> (key,data)::l) ~compare_key) ;; let concat t1 t2 = match (t1, t2) with | (Empty, t) -> t | (t, Empty) -> t | (_, _) -> let (x, d) = min_elt_exn t2 in bal t1 x d (remove_min_elt t2) ;; let rec remove t x ~length ~compare_key = match t with | Empty -> (Empty, length) | Leaf (v, _) -> if compare_key x v = 0 then (Empty, length - 1) else (t, length) | Node(l, v, d, r, _) -> let c = compare_key x v in if c = 0 then (concat l r, length - 1) else if c < 0 then let l, length = remove l x ~length ~compare_key in (bal l v d r, length) else let r, length = remove r x ~length ~compare_key in (bal l v d r, length) ;; (* Use exception to avoid tree-rebuild in no-op case *) exception Change_no_op let change t key f ~length ~compare_key = let rec change_core t key f = match t with | Empty -> begin match (f None) with | None -> raise Change_no_op (* equivalent to returning: Empty *) | Some data -> (Leaf(key, data), length + 1) end | Leaf(v, d) -> let c = compare_key key v in if c = 0 then match f (Some d) with | None -> (Empty, length - 1) | Some d' -> (Leaf(v, d'), length) else if c < 0 then let l, length = change_core Empty key f in (bal l v d Empty, length) else let r, length = change_core Empty key f in (bal Empty v d r, length) | Node(l, v, d, r, h) -> let c = compare_key key v in if c = 0 then begin match (f (Some d)) with | None -> (concat l r, length - 1) | Some data -> (Node(l, key, data, r, h), length) end else if c < 0 then let l, length = change_core l key f in (bal l v d r, length) else let r, length = change_core r key f in (bal l v d r, length) in try change_core t key f with Change_no_op -> (t, length) ;; let rec iter t ~f = match t with | Empty -> () | Leaf(v, d) -> f ~key:v ~data:d | Node(l, v, d, r, _) -> iter ~f l; f ~key:v ~data:d; iter ~f r ;; let rec map t ~f = match t with | Empty -> Empty | Leaf(v, d) -> Leaf(v, f d) | Node(l, v, d, r, h) -> let l' = map ~f l in let d' = f d in let r' = map ~f r in Node(l', v, d', r', h) ;; let rec mapi t ~f = match t with | Empty -> Empty | Leaf(v, d) -> Leaf(v, f ~key:v ~data:d) | Node(l, v, d, r, h) -> let l' = mapi ~f l in let d' = f ~key:v ~data:d in let r' = mapi ~f r in Node(l', v, d', r', h) ;; let rec fold t ~init:accu ~f = match t with | Empty -> accu | Leaf(v, d) -> f ~key:v ~data:d accu | Node(l, v, d, r, _) -> fold ~f r ~init:(f ~key:v ~data:d (fold ~f l ~init:accu)) ;; let rec fold_right t ~init:accu ~f = match t with | Empty -> accu | Leaf(v, d) -> f ~key:v ~data:d accu | Node(l, v, d, r, _) -> fold_right ~f l ~init:(f ~key:v ~data:d (fold_right ~f r ~init:accu)) ;; let filter t ~f ~compare_key = fold ~init:(Empty, 0) t ~f:(fun ~key ~data (accu, length) -> if f ~key ~data then add ~length ~key ~data accu ~compare_key else (accu, length)) ;; let filter_map t ~f ~compare_key = fold ~init:(Empty, 0) t ~f:(fun ~key ~data (accu, length) -> match f data with | None -> (accu, length) | Some b -> add ~length ~key ~data:b accu ~compare_key) ;; let filter_mapi t ~f ~compare_key = fold ~init:(Empty, 0) t ~f:(fun ~key ~data (accu, length) -> match f ~key ~data with | None -> (accu, length) | Some b -> add ~length ~key ~data:b accu ~compare_key) ;; module Enum = struct type increasing type decreasing type ('k, 'v, 'direction) t = | End | More of 'k * 'v * ('k, 'v) tree * ('k, 'v, 'direction) t let rec cons t (e : (_, _, increasing) t) : (_, _, increasing) t = match t with | Empty -> e | Leaf(v, d) -> More(v, d, Empty, e) | Node(l, v, d, r, _) -> cons l (More(v, d, r, e)) ;; let rec cons_right t (e : (_, _, decreasing) t) : (_, _, decreasing) t = match t with | Empty -> e | Leaf(v, d) -> More(v, d, Empty, e) | Node(l, v, d, r, _) -> cons_right r (More(v, d, l, e)) ;; let of_tree tree : (_, _, increasing) t = cons tree End ;; let of_tree_right tree : (_, _, decreasing) t = cons_right tree End ;; let starting_at_increasing t key compare : (_, _, increasing) t = let rec loop t e = match t with | Empty -> e | Leaf(v, d) -> loop (Node(Empty, v, d, Empty, 1)) e | Node(_, v, _, r, _) when compare v key < 0 -> loop r e | Node(l, v, d, r, _) -> loop l (More(v, d, r, e)) in loop t End ;; let starting_at_decreasing t key compare : (_, _, decreasing) t = let rec loop t e = match t with | Empty -> e | Leaf(v, d) -> loop (Node(Empty, v, d, Empty, 1)) e | Node(l, v, _, _, _) when compare v key > 0 -> loop l e | Node(l, v, d, r, _) -> loop r (More(v, d, l, e)) in loop t End ;; let compare compare_key compare_data t1 t2 = let rec loop t1 t2 = match t1, t2 with | (End, End) -> 0 | (End, _) -> -1 | (_, End) -> 1 | (More (v1, d1, r1, e1), More (v2, d2, r2, e2)) -> let c = compare_key v1 v2 in if c <> 0 then c else let c = compare_data d1 d2 in if c <> 0 then c else loop (cons r1 e1) (cons r2 e2) in loop t1 t2 ;; let equal compare_key data_equal t1 t2 = let rec loop t1 t2 = match t1, t2 with | (End, End) -> true | (End, _) | (_, End) -> false | (More (v1, d1, r1, e1), More (v2, d2, r2, e2)) -> compare_key v1 v2 = 0 && data_equal d1 d2 && loop (cons r1 e1) (cons r2 e2) in loop t1 t2 ;; let rec iter ~f = function | End -> () | More (key, data, tree, enum) -> f ~key ~data; iter (cons tree enum) ~f ;; let iter2 compare_key t1 t2 ~f = let rec loop t1 t2 = match t1, t2 with | End, End -> () | End, _ -> iter t2 ~f:(fun ~key ~data -> f ~key ~data:(`Right data)) | _ , End -> iter t1 ~f:(fun ~key ~data -> f ~key ~data:(`Left data)) | More (k1, v1, tree1, enum1), More (k2, v2, tree2, enum2) -> let compare_result = compare_key k1 k2 in if compare_result = 0 then begin f ~key:k1 ~data:(`Both (v1, v2)); loop (cons tree1 enum1) (cons tree2 enum2) end else if compare_result < 0 then begin f ~key:k1 ~data:(`Left v1); loop (cons tree1 enum1) t2 end else begin f ~key:k2 ~data:(`Right v2); loop t1 (cons tree2 enum2) end in loop t1 t2 ;; let symmetric_diff t1 t2 ~compare_key ~data_equal = let step state = match state with | End, End -> Sequence.Step.Done | End, More (key, data, tree, enum) -> Sequence.Step.Yield ((key, `Right data), (End, cons tree enum)) | More (key, data, tree, enum), End -> Sequence.Step.Yield ((key, `Left data), (cons tree enum, End)) | (More (k1, v1, tree1, enum1) as left), (More (k2, v2, tree2, enum2) as right) -> let compare_result = compare_key k1 k2 in if compare_result = 0 then begin let next_state = if Pervasives.(==) tree1 tree2 then (enum1, enum2) else (cons tree1 enum1, cons tree2 enum2) in if data_equal v1 v2 then Sequence.Step.Skip next_state else Sequence.Step.Yield ((k1, `Unequal (v1, v2)), next_state) end else if compare_result < 0 then begin Sequence.Step.Yield ((k1, `Left v1), (cons tree1 enum1, right)) end else begin Sequence.Step.Yield ((k2, `Right v2), (left, (cons tree2 enum2))) end in Sequence.unfold_step ~init:(of_tree t1, of_tree t2) ~f:step ;; end let to_sequence_increasing comparator ~from_key t = let next enum = match enum with | Enum.End -> Sequence.Step.Done | Enum.More(k,v,t,e) -> Sequence.Step.Yield((k,v), Enum.cons t e) in let init = match from_key with | None -> Enum.of_tree t | Some key -> Enum.starting_at_increasing t key comparator.Comparator.compare in Sequence.unfold_step ~init ~f:next ;; let to_sequence_decreasing comparator ~from_key t = let next enum = match enum with | Enum.End -> Sequence.Step.Done | Enum.More(k,v,t,e) -> Sequence.Step.Yield((k,v), Enum.cons_right t e) in let init = match from_key with | None -> Enum.of_tree_right t | Some key -> Enum.starting_at_decreasing t key comparator.Comparator.compare in Sequence.unfold_step ~init ~f:next ;; let to_sequence comparator ?(order=`Increasing_key) ?keys_greater_or_equal_to ?keys_less_or_equal_to t = let inclusive_bound side t bound = let compare_key = comparator.Comparator.compare in let l, maybe, r = split t bound ~compare_key in let t = side (l, r) in match maybe with | None -> t | Some (key, data) -> add' t key data ~compare_key in match order with | `Increasing_key -> let t = Option.fold keys_less_or_equal_to ~init:t ~f:(inclusive_bound fst) in to_sequence_increasing comparator ~from_key:keys_greater_or_equal_to t | `Decreasing_key -> let t = Option.fold keys_greater_or_equal_to ~init:t ~f:(inclusive_bound snd) in to_sequence_decreasing comparator ~from_key:keys_less_or_equal_to t ;; let compare compare_key compare_data t1 t2 = Enum.compare compare_key compare_data (Enum.of_tree t1) (Enum.of_tree t2) ;; let equal compare_key compare_data t1 t2 = Enum.equal compare_key compare_data (Enum.of_tree t1) (Enum.of_tree t2) ;; let iter2 t1 t2 ~f ~compare_key = Enum.iter2 compare_key (Enum.of_tree t1) (Enum.of_tree t2) ~f ;; let symmetric_diff = Enum.symmetric_diff let rec length = function | Empty -> 0 | Leaf _ -> 1 | Node (l, _, _, r, _) -> length l + length r + 1 ;; let of_alist_fold alist ~init ~f ~compare_key = List.fold alist ~init:(empty, 0) ~f:(fun (accum, length) (key, data) -> let prev_data = match find accum key ~compare_key with | None -> init | Some prev -> prev in let data = f prev_data data in add accum ~length ~key ~data ~compare_key) ;; let of_alist_reduce alist ~f ~compare_key = List.fold alist ~init:(empty, 0) ~f:(fun (accum, length) (key, data) -> let new_data = match find accum key ~compare_key with | None -> data | Some prev -> f prev data in add accum ~length ~key ~data:new_data ~compare_key) ;; let keys t = fold_right ~f:(fun ~key ~data:_ list -> key::list) t ~init:[] let data t = fold_right ~f:(fun ~key:_ ~data list -> data::list) t ~init:[] let of_alist alist ~compare_key = with_return (fun r -> let map = List.fold alist ~init:(empty, 0) ~f:(fun (t, length) (key,data) -> if mem t key ~compare_key then r.return (`Duplicate_key key) else add ~length ~key ~data t ~compare_key) in `Ok map) let for_all t ~f = with_return (fun r -> iter t ~f:(fun ~key:_ ~data -> if not (f data) then r.return false); true) let exists t ~f = with_return (fun r -> iter t ~f:(fun ~key:_ ~data -> if f data then r.return true); false) let of_alist_or_error alist ~comparator = match of_alist alist ~compare_key:comparator.Comparator.compare with | `Ok x -> Result.Ok x | `Duplicate_key key -> let sexp_of_key = comparator.Comparator.sexp_of_t in Or_error.error "Map.of_alist_exn: duplicate key" key <:sexp_of< key >> ;; let of_alist_exn alist ~comparator = match of_alist_or_error alist ~comparator with | Result.Ok x -> x | Result.Error e -> Error.raise e ;; let of_alist_multi alist ~compare_key = let alist = List.rev alist in of_alist_fold alist ~init:[] ~f:(fun l x -> x :: l) ~compare_key ;; let to_alist t = fold_right t ~init:[] ~f:(fun ~key ~data x -> (key,data)::x) ;; let merge t1 t2 ~f ~compare_key = let elts = Core_array.create ~len:(length t1 + length t2) (Obj.magic None) in let i = ref 0 in iter2 t1 t2 ~compare_key ~f:(fun ~key ~data:values -> match f ~key values with | Some value -> elts.(!i) <- (key, value); incr i | None -> ()); (* [Core_array.truncate] raises if [len = 0] *) if !i = 0 then (empty, 0) else begin Core_array.truncate elts ~len:!i; of_sorted_array_unchecked ~compare_key elts end ;; module Closest_key_impl = struct (* [marker] and [repackage] allow us to create "logical" options without actually allocating any options. Passing [Found key value] to a function is equivalent to passing [Some (key, value)]; passing [Missing () ()] is equivalent to passing [None]. *) type ('k, 'v, 'k_opt, 'v_opt) marker = | Missing : ('k, 'v, unit, unit) marker | Found : ('k, 'v, 'k, 'v) marker let repackage (type k) (type v) (type k_opt) (type v_opt) (marker : (k, v, k_opt, v_opt) marker) (k : k_opt) (v : v_opt) : (k * v) option = match marker with | Missing -> None | Found -> Some (k, v) ;; (* The type signature is explicit here to allow polymorphic recursion. *) let rec loop : 'k 'v 'k_opt 'v_opt. ('k, 'v) tree -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'k -> compare_key:('k -> 'k -> int) -> ('k, 'v, 'k_opt, 'v_opt) marker -> 'k_opt -> 'v_opt -> ('k * 'v) option = fun t dir k ~compare_key found_marker found_key found_value -> match t with | Empty -> repackage found_marker found_key found_value | Leaf (k', v') -> let c = compare_key k' k in if match dir with | `Greater_or_equal_to -> c >= 0 | `Greater_than -> c > 0 | `Less_or_equal_to -> c <= 0 | `Less_than -> c < 0 then Some (k', v') else repackage found_marker found_key found_value | Node (l, k', v', r, _) -> let c = compare_key k' k in if c = 0 then begin (* This is a base case (no recursive call). *) match dir with | `Greater_or_equal_to | `Less_or_equal_to -> Some (k', v') | `Greater_than -> if is_empty r then repackage found_marker found_key found_value else min_elt r | `Less_than -> if is_empty l then repackage found_marker found_key found_value else max_elt l end else begin (* We are guaranteed here that k' <> k. *) (* This is the only recursive case. *) match dir with | `Greater_or_equal_to | `Greater_than -> if c > 0 then loop l dir k ~compare_key Found k' v' else loop r dir k ~compare_key found_marker found_key found_value | `Less_or_equal_to | `Less_than -> if c < 0 then loop r dir k ~compare_key Found k' v' else loop l dir k ~compare_key found_marker found_key found_value end ;; let closest_key t dir k ~compare_key = loop t dir k ~compare_key Missing () () ;; end let closest_key = Closest_key_impl.closest_key let rec rank t k ~compare_key = match t with | Empty -> None | Leaf (k', _) -> if compare_key k' k = 0 then Some 0 else None | Node (l, k', _, r, _) -> let c = compare_key k' k in if c = 0 then Some (length l) else if c > 0 then rank l k ~compare_key else Option.map (rank r k ~compare_key) ~f:(fun rank -> rank + 1 + (length l)) ;; (* this could be implemented using [Sequence] interface but the following implementation allocates only 2 words and doesn't require write-barrier *) let rec nth' num_to_search = function | Empty -> None | Leaf (k, v) -> if !num_to_search = 0 then Some (k, v) else begin decr num_to_search; None end | Node (l, k, v, r, _) -> match nth' num_to_search l with | (Some _) as some -> some | None -> if !num_to_search = 0 then Some (k, v) else begin decr num_to_search; nth' num_to_search r end let nth t n = nth' (ref n) t ;; let t_of_sexp key_of_sexp value_of_sexp sexp ~comparator = let alist = <:of_sexp< (key * value) list >> sexp in of_alist_exn alist ~comparator ;; let sexp_of_t sexp_of_key sexp_of_value t = let f ~key ~data acc = Sexp.List [sexp_of_key key; sexp_of_value data] :: acc in Sexp.List (fold_right ~f t ~init:[]) ;; end type ('k, 'v, 'comparator) t = { (* [comparator] is the first field so that polymorphic comparisons fail on a map due to the functional value in the comparator. *) comparator : ('k, 'comparator) Comparator.t; tree : ('k, 'v) Tree0.t; length : int; } let comparator t = t.comparator type ('k, 'v, 'comparator) tree = ('k, 'v) Tree0.t let compare_key t = t.comparator.Comparator.compare let like {tree = _; length = _; comparator} (tree, length) = {tree; length; comparator} let with_same_length { tree = _; comparator; length } tree = { tree; comparator; length } let of_tree ~comparator tree = { tree; comparator; length = Tree0.length tree} module Accessors = struct let to_tree t = t.tree let invariants t = Tree0.invariants t.tree ~compare_key:(compare_key t) let is_empty t = Tree0.is_empty t.tree let length t = t.length let add t ~key ~data = like t (Tree0.add t.tree ~length:t.length ~key ~data ~compare_key:(compare_key t)) ;; let add_multi t ~key ~data = like t (Tree0.add_multi t.tree ~length:t.length ~key ~data ~compare_key:(compare_key t)) ;; let change t key f = like t (Tree0.change t.tree key f ~length:t.length ~compare_key:(compare_key t)) ;; let find_exn t key = Tree0.find_exn t.tree key ~compare_key:(compare_key t) let find t key = Tree0.find t.tree key ~compare_key:(compare_key t) let remove t key = like t (Tree0.remove t.tree key ~length:t.length ~compare_key:(compare_key t)) ;; let mem t key = Tree0.mem t.tree key ~compare_key:(compare_key t) let iter t ~f = Tree0.iter t.tree ~f let iter2 t1 t2 ~f = Tree0.iter2 t1.tree t2.tree ~f ~compare_key:(compare_key t1) let map t ~f = with_same_length t (Tree0.map t.tree ~f) let mapi t ~f = with_same_length t (Tree0.mapi t.tree ~f) let fold t ~init ~f = Tree0.fold t.tree ~f ~init let fold_right t ~init ~f = Tree0.fold_right t.tree ~f ~init let filter t ~f = like t (Tree0.filter t.tree ~f ~compare_key:(compare_key t)) let filter_map t ~f = like t (Tree0.filter_map t.tree ~f ~compare_key:(compare_key t)) let filter_mapi t ~f = like t (Tree0.filter_mapi t.tree ~f ~compare_key:(compare_key t)) let compare_direct compare_data t1 t2 = Tree0.compare (compare_key t1) compare_data t1.tree t2.tree ;; let equal compare_data t1 t2 = Tree0.equal (compare_key t1) compare_data t1.tree t2.tree ;; let keys t = Tree0.keys t.tree let data t = Tree0.data t.tree let to_alist t = Tree0.to_alist t.tree let validate ~name f t = Validate.alist ~name f (to_alist t) let symmetric_diff t1 t2 ~data_equal = Tree0.symmetric_diff t1.tree t2.tree ~compare_key:(compare_key t1) ~data_equal ;; let merge t1 t2 ~f = like t1 (Tree0.merge t1.tree t2.tree ~f ~compare_key:(compare_key t1)) ;; let min_elt t = Tree0.min_elt t.tree let min_elt_exn t = Tree0.min_elt_exn t.tree let max_elt t = Tree0.max_elt t.tree let max_elt_exn t = Tree0.max_elt_exn t.tree let for_all t ~f = Tree0.for_all t.tree ~f let exists t ~f = Tree0.exists t.tree ~f let split t k = let l, maybe, r = Tree0.split t.tree k ~compare_key:(compare_key t) in (of_tree l ~comparator:(comparator t), maybe, of_tree r ~comparator:(comparator t)) ;; let fold_range_inclusive t ~min ~max ~init ~f = Tree0.fold_range_inclusive t.tree ~min ~max ~init ~f ~compare_key:(compare_key t) ;; let range_to_alist t ~min ~max = Tree0.range_to_alist t.tree ~min ~max ~compare_key:(compare_key t) ;; let closest_key t dir key = Tree0.closest_key t.tree dir key ~compare_key:(compare_key t) let nth t n = Tree0.nth t.tree n let rank t key = Tree0.rank t.tree key ~compare_key:(compare_key t) let sexp_of_t sexp_of_k sexp_of_v t = Tree0.sexp_of_t sexp_of_k sexp_of_v t.tree let to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t = Tree0.to_sequence t.comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t.tree end let empty ~comparator = { tree = Tree0.empty; comparator; length = 0 } let singleton ~comparator k v = { comparator; tree = Tree0.singleton k v; length = 1 } let of_tree0 ~comparator (tree, length) = { comparator; tree; length } let of_sorted_array_unchecked ~comparator array = of_tree0 ~comparator (Tree0.of_sorted_array_unchecked array ~compare_key:comparator.Comparator.compare) ;; let of_sorted_array ~comparator array = Or_error.map (Tree0.of_sorted_array array ~compare_key:comparator.Comparator.compare) ~f:(fun tree -> of_tree0 ~comparator tree) ;; let of_alist ~comparator alist = match Tree0.of_alist alist ~compare_key:comparator.Comparator.compare with | `Ok (tree, length) -> `Ok { comparator; tree; length } | `Duplicate_key _ as z -> z ;; let of_alist_or_error ~comparator alist = Result.map (Tree0.of_alist_or_error alist ~comparator) ~f:(fun tree -> of_tree0 ~comparator tree) ;; let of_alist_exn ~comparator alist = of_tree0 ~comparator (Tree0.of_alist_exn alist ~comparator) ;; let of_alist_multi ~comparator alist = of_tree0 ~comparator (Tree0.of_alist_multi alist ~compare_key:comparator.Comparator.compare) ;; let of_alist_fold ~comparator alist ~init ~f = of_tree0 ~comparator (Tree0.of_alist_fold alist ~init ~f ~compare_key:comparator.Comparator.compare) ;; let of_alist_reduce ~comparator alist ~f = of_tree0 ~comparator (Tree0.of_alist_reduce alist ~f ~compare_key:comparator.Comparator.compare) ;; let t_of_sexp ~comparator k_of_sexp v_of_sexp sexp = of_tree0 ~comparator (Tree0.t_of_sexp k_of_sexp v_of_sexp sexp ~comparator) ;; module Creators (Key : Comparator.S1) : sig type ('a, 'b, 'c) t_ = ('a Key.t, 'b, Key.comparator_witness) t type ('a, 'b, 'c) tree = ('a, 'b) Tree0.t type ('a, 'b, 'c) options = ('a, 'b, 'c) Without_comparator.t val t_of_sexp : (Sexp.t -> 'a Key.t) -> (Sexp.t -> 'b) -> Sexp.t -> ('a, 'b, _) t_ include Creators_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t_ with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a Key.t with type ('a, 'b, 'c) options := ('a, 'b, 'c) options end = struct type ('a, 'b, 'c) options = ('a, 'b, 'c) Without_comparator.t let comparator = Key.comparator type ('a, 'b, 'c) t_ = ('a Key.t, 'b, Key.comparator_witness) t type ('a, 'b, 'c) tree = ('a, 'b) Tree0.t let empty = { tree = Tree0.empty; comparator; length = 0 } let of_tree tree = of_tree ~comparator tree let singleton k v = singleton ~comparator k v let of_sorted_array_unchecked array = of_sorted_array_unchecked ~comparator array let of_sorted_array array = of_sorted_array ~comparator array let of_alist alist = of_alist ~comparator alist let of_alist_or_error alist = of_alist_or_error ~comparator alist let of_alist_exn alist = of_alist_exn ~comparator alist let of_alist_multi alist = of_alist_multi ~comparator alist let of_alist_fold alist ~init ~f = of_alist_fold ~comparator alist ~init ~f let of_alist_reduce alist ~f = of_alist_reduce ~comparator alist ~f let t_of_sexp k_of_sexp v_of_sexp sexp = t_of_sexp ~comparator k_of_sexp v_of_sexp sexp end include Accessors (* [0] is used as the [length] argument everywhere in this module, since trees do not have their lengths stored at the root, unlike maps. The values are discarded always. *) module Make_tree (Key : Comparator.S1) = struct let comparator = Key.comparator let empty = Tree0.empty let of_tree tree = tree let singleton k v = Tree0.singleton k v let of_sorted_array_unchecked array = fst (Tree0.of_sorted_array_unchecked array ~compare_key:comparator.Comparator.compare) ;; let of_sorted_array array = Tree0.of_sorted_array array ~compare_key:comparator.Comparator.compare |> Or_error.map ~f:fst ;; let of_alist alist = match Tree0.of_alist alist ~compare_key:comparator.Comparator.compare with | `Duplicate_key _ as d -> d | `Ok (tree, _size) -> `Ok tree ;; let of_alist_or_error alist = Or_error.map ~f:fst (Tree0.of_alist_or_error alist ~comparator) ;; let of_alist_exn alist = fst (Tree0.of_alist_exn alist ~comparator) let of_alist_multi alist = fst (Tree0.of_alist_multi alist ~compare_key:comparator.Comparator.compare) ;; let of_alist_fold alist ~init ~f = Tree0.of_alist_fold alist ~init ~f ~compare_key:comparator.Comparator.compare |> fst ;; let of_alist_reduce alist ~f = Tree0.of_alist_reduce alist ~f ~compare_key:comparator.Comparator.compare |> fst ;; let to_tree t = t let invariants t = Tree0.invariants t ~compare_key:comparator.Comparator.compare let is_empty t = Tree0.is_empty t let length t = Tree0.length t let add t ~key ~data = fst (Tree0.add t ~key ~data ~length:0 ~compare_key:comparator.Comparator.compare) ;; let add_multi t ~key ~data = fst (Tree0.add_multi t ~key ~data ~length:0 ~compare_key:comparator.Comparator.compare) ;; let change t key f = fst (Tree0.change t key f ~length:0 ~compare_key:comparator.Comparator.compare) ;; let find_exn t key = Tree0.find_exn t key ~compare_key:comparator.Comparator.compare ;; let find t key = Tree0.find t key ~compare_key:comparator.Comparator.compare ;; let remove t key = fst (Tree0.remove t key ~length:0 ~compare_key:comparator.Comparator.compare) ;; let mem t key = Tree0.mem t key ~compare_key:comparator.Comparator.compare let iter t ~f = Tree0.iter t ~f let iter2 t1 t2 ~f = Tree0.iter2 t1 t2 ~f ~compare_key:comparator.Comparator.compare let map t ~f = Tree0.map t ~f let mapi t ~f = Tree0.mapi t ~f let fold t ~init ~f = Tree0.fold t ~f ~init let fold_right t ~init ~f = Tree0.fold_right t ~f ~init let filter t ~f = fst (Tree0.filter t ~f ~compare_key:comparator.Comparator.compare) let filter_map t ~f = fst (Tree0.filter_map t ~f ~compare_key:comparator.Comparator.compare) let filter_mapi t ~f = fst (Tree0.filter_mapi t ~f ~compare_key:comparator.Comparator.compare) let compare_direct compare_data t1 t2 = Tree0.compare comparator.Comparator.compare compare_data t1 t2 ;; let equal compare_data t1 t2 = Tree0.equal comparator.Comparator.compare compare_data t1 t2 ;; let keys t = Tree0.keys t let data t = Tree0.data t let to_alist t = Tree0.to_alist t let validate ~name f t = Validate.alist ~name f (to_alist t) let symmetric_diff t1 t2 ~data_equal = Tree0.symmetric_diff t1 t2 ~compare_key:comparator.Comparator.compare ~data_equal ;; let merge t1 t2 ~f = fst (Tree0.merge t1 t2 ~f ~compare_key:comparator.Comparator.compare) let min_elt t = Tree0.min_elt t let min_elt_exn t = Tree0.min_elt_exn t let max_elt t = Tree0.max_elt t let max_elt_exn t = Tree0.max_elt_exn t let for_all t ~f = Tree0.for_all t ~f let exists t ~f = Tree0.exists t ~f let split t k = Tree0.split t k ~compare_key:comparator.Comparator.compare let fold_range_inclusive t ~min ~max ~init ~f = Tree0.fold_range_inclusive t ~min ~max ~init ~f ~compare_key:comparator.Comparator.compare ;; let range_to_alist t ~min ~max = Tree0.range_to_alist t ~min ~max ~compare_key:comparator.Comparator.compare ;; let closest_key t dir key = Tree0.closest_key t dir key ~compare_key:comparator.Comparator.compare ;; let nth t n = Tree0.nth t n ;; let rank t key = Tree0.rank t key ~compare_key:comparator.Comparator.compare let to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t = Tree0.to_sequence comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t end module Poly = struct include Creators (Comparator.Poly) type ('a, 'b, 'c) map = ('a, 'b, 'c) t type ('k, 'v) t = ('k, 'v, Comparator.Poly.comparator_witness) map include Accessors let compare _ cmpv t1 t2 = compare_direct cmpv t1 t2 let sexp_of_t = sexp_of_t include Bin_prot.Utils.Make_iterable_binable2 (struct type ('a, 'b) acc = ('a , 'b) t type ('a, 'b) t = ('a, 'b) acc type ('a, 'b) el = 'a * 'b with bin_io let _ = bin_el let module_name = Some "Core.Std.Map" let length = length let iter t ~f = iter t ~f:(fun ~key ~data -> f (key, data)) let init _n = empty let insert acc (key, data) _i = if mem acc key then failwith "Map.bin_read_t_: duplicate element in map" else add ~key ~data acc ;; let finish t = t end) module Tree = struct include Make_tree (Comparator.Poly) type ('k, +'v) t = ('k, 'v, Comparator.Poly.comparator_witness) tree let sexp_of_t sexp_of_k sexp_of_v t = Tree0.sexp_of_t sexp_of_k sexp_of_v t let t_of_sexp k_of_sexp v_of_sexp sexp = fst (Tree0.t_of_sexp k_of_sexp v_of_sexp ~comparator:Comparator.Poly.comparator sexp) end end module type Key = Key module type Key_binable = Key_binable module type S = S with type ('a, 'b, 'c) map := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree module type S_binable = S_binable with type ('a, 'b, 'c) map := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree module Make_using_comparator (Key : sig type t with sexp include Comparator.S with type t := t end) = struct module Key = Key module Key_S1 = Comparator.S_to_S1 (Key) include Creators (Key_S1) type key = Key.t type ('a, 'b, 'c) map = ('a, 'b, 'c) t type 'v t = (key, 'v, Key.comparator_witness) map include Accessors let compare cmpv t1 t2 = compare_direct cmpv t1 t2 let sexp_of_t sexp_of_v t = sexp_of_t Key.sexp_of_t sexp_of_v t let t_of_sexp v_of_sexp sexp = t_of_sexp Key.t_of_sexp v_of_sexp sexp module Tree = struct include Make_tree (Key_S1) type +'v t = (Key.t, 'v, Key.comparator_witness) tree let sexp_of_t sexp_of_v t = Tree0.sexp_of_t Key.sexp_of_t sexp_of_v t let t_of_sexp v_of_sexp sexp = Tree0.t_of_sexp Key.t_of_sexp v_of_sexp ~comparator:Key.comparator sexp |> fst end end module Make (Key : Key) = Make_using_comparator (struct include Key include Comparator.Make (Key) end) module Make_binable_using_comparator (Key' : sig type t with bin_io, sexp include Comparator.S with type t := t end) = struct include Make_using_comparator (Key') include Bin_prot.Utils.Make_iterable_binable1 (struct type 'v acc = 'v t type 'v t = 'v acc type 'v el = Key'.t * 'v with bin_io let _ = bin_el let module_name = Some "Core.Std.Map" let length = length let iter t ~f = iter t ~f:(fun ~key ~data -> f (key, data)) let init _n = empty let insert acc (key, data) _i = if mem acc key then failwith "Map.bin_read_t_: duplicate element in map" else add ~key ~data acc ;; let finish t = t end) end module Make_binable (Key : Key_binable) = Make_binable_using_comparator (struct include Key include Comparator.Make (Key) end) (* As with [Make_tree], this module uses [0] as [length] everywhere. *) module Tree = struct type ('k, 'v, 'comparator) t = ('k, 'v, 'comparator) tree let empty ~comparator:_ = Tree0.empty let of_tree ~comparator:_ tree = tree let singleton ~comparator:_ k v = Tree0.singleton k v let of_sorted_array_unchecked ~comparator array = fst (Tree0.of_sorted_array_unchecked array ~compare_key:comparator.Comparator.compare) ;; let of_sorted_array ~comparator array = Tree0.of_sorted_array array ~compare_key:comparator.Comparator.compare |> Or_error.map ~f:fst ;; let of_alist ~comparator alist = match Tree0.of_alist alist ~compare_key:comparator.Comparator.compare with | `Duplicate_key _ as d -> d | `Ok (tree, _size) -> `Ok tree ;; let of_alist_or_error ~comparator alist = Tree0.of_alist_or_error alist ~comparator |> Or_error.map ~f:fst let of_alist_exn ~comparator alist = fst (Tree0.of_alist_exn alist ~comparator) let of_alist_multi ~comparator alist = fst (Tree0.of_alist_multi alist ~compare_key:comparator.Comparator.compare) ;; let of_alist_fold ~comparator alist ~init ~f = fst (Tree0.of_alist_fold alist ~init ~f ~compare_key:comparator.Comparator.compare) ;; let of_alist_reduce ~comparator alist ~f = fst (Tree0.of_alist_reduce alist ~f ~compare_key:comparator.Comparator.compare) ;; let to_tree t = t let invariants ~comparator t = Tree0.invariants t ~compare_key:comparator.Comparator.compare ;; let is_empty t = Tree0.is_empty t let length t = Tree0.length t let add ~comparator t ~key ~data = fst (Tree0.add t ~key ~data ~length:0 ~compare_key:comparator.Comparator.compare) ;; let add_multi ~comparator t ~key ~data = Tree0.add_multi t ~key ~data ~length:0 ~compare_key:comparator.Comparator.compare |> fst ;; let change ~comparator t key f = fst (Tree0.change t key f ~length:0 ~compare_key:comparator.Comparator.compare) ;; let find_exn ~comparator t key = Tree0.find_exn t key ~compare_key:comparator.Comparator.compare ;; let find ~comparator t key = Tree0.find t key ~compare_key:comparator.Comparator.compare ;; let remove ~comparator t key = fst (Tree0.remove t key ~length:0 ~compare_key:comparator.Comparator.compare) ;; let mem ~comparator t key = Tree0.mem t key ~compare_key:comparator.Comparator.compare let iter t ~f = Tree0.iter t ~f let iter2 ~comparator t1 t2 ~f = Tree0.iter2 t1 t2 ~f ~compare_key:comparator.Comparator.compare ;; let map t ~f = Tree0.map t ~f let mapi t ~f = Tree0.mapi t ~f let fold t ~init ~f = Tree0.fold t ~f ~init let fold_right t ~init ~f = Tree0.fold_right t ~f ~init let filter ~comparator t ~f = fst (Tree0.filter t ~f ~compare_key:comparator.Comparator.compare) ;; let filter_map ~comparator t ~f = fst (Tree0.filter_map t ~f ~compare_key:comparator.Comparator.compare) ;; let filter_mapi ~comparator t ~f = fst (Tree0.filter_mapi t ~f ~compare_key:comparator.Comparator.compare) ;; let compare_direct ~comparator compare_data t1 t2 = Tree0.compare comparator.Comparator.compare compare_data t1 t2 ;; let equal ~comparator compare_data t1 t2 = Tree0.equal comparator.Comparator.compare compare_data t1 t2 ;; let keys t = Tree0.keys t let data t = Tree0.data t let to_alist t = Tree0.to_alist t let validate ~name f t = Validate.alist ~name f (to_alist t) let symmetric_diff ~comparator t1 t2 ~data_equal = Tree0.symmetric_diff t1 t2 ~compare_key:comparator.Comparator.compare ~data_equal ;; let merge ~comparator t1 t2 ~f = fst (Tree0.merge t1 t2 ~f ~compare_key:comparator.Comparator.compare) ;; let min_elt t = Tree0.min_elt t let min_elt_exn t = Tree0.min_elt_exn t let max_elt t = Tree0.max_elt t let max_elt_exn t = Tree0.max_elt_exn t let for_all t ~f = Tree0.for_all t ~f let exists t ~f = Tree0.exists t ~f let split ~comparator t k = Tree0.split t k ~compare_key:comparator.Comparator.compare let fold_range_inclusive ~comparator t ~min ~max ~init ~f = Tree0.fold_range_inclusive t ~min ~max ~init ~f ~compare_key:comparator.Comparator.compare ;; let range_to_alist ~comparator t ~min ~max = Tree0.range_to_alist t ~min ~max ~compare_key:comparator.Comparator.compare ;; let closest_key ~comparator t dir key = Tree0.closest_key t dir key ~compare_key:comparator.Comparator.compare ;; let nth ~comparator:_ t n = Tree0.nth t n let rank ~comparator t key = Tree0.rank t key ~compare_key:comparator.Comparator.compare let sexp_of_t sexp_of_k sexp_of_v _ t = Tree0.sexp_of_t sexp_of_k sexp_of_v t let to_sequence ~comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t = Tree0.to_sequence comparator ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t end core_kernel-113.00.00/src/core_map.mli000066400000000000000000000400511256461164500173750ustar00rootroot00000000000000(** This module defines the [Map] module for [Core.Std]. We use "core_map" as the file name rather than "map" to avoid conflicts with OCaml's standard map module. In this documentation, we use [Map] to mean this module, not the OCaml standard one. [Map] is a functional datastructure (balanced binary tree) implementing finite maps over a totally-ordered domain, called a "key". The map types and operations appear in three places: {v | Map | polymorphic map operations | | Map.Poly | maps that use polymorphic comparison to order keys | | Key.Map | maps with a fixed key type that use [Key.compare] to order keys | v} Where [Key] is any module defining values that can be used as keys of a map, like [Int], [String], etc. To add this functionality to an arbitrary module, use the [Comparable.Make] functor. One should use [Map] for functions that access existing maps, like [find], [mem], [add], [fold], [iter], and [to_alist]. For functions that create maps, like [empty], [singleton], and [of_alist], one should strive to use the corresponding [Key.Map] function, which will use the comparison function specifically for [Key]. As a last resort, if one does not have easy access to a comparison function for the keys in one's map, use [Map.Poly] to create the map. This will use OCaml's built-in polymorphic comparison to compare keys, which has all the usual performance and robustness problems that entails. Parallel to the three kinds of map modules, there are also tree modules [Map.Tree], [Map.Poly.Tree], and [Key.Map.Tree]. A tree is a bare representation of a map, without the comparator. Thus tree operations need to obtain the comparator from somewhere. For [Map.Poly.Tree] and [Key.Map.Tree], the comparator is implicit in the module name. For [Map.Tree], the comparator must be passed to each operation. The main advantages of trees over maps are slightly improved space usage (there is no outer container holding the comparator) and the ability to marshal trees, because a tree doesn't contain a closure, unlike a map. The main disadvantages of using trees are needing to be more explicit about the comparator, and the possibility of accidental use of polymorphic equality on a tree (for which maps dynamically detect failure due to the presence of a closure in the data structure). For a detailed explanation of the interface design, read on. An instance of the map type is determined by the types of the map's keys and values, and the comparison function used to order the keys: {[ type ('key, 'value, 'cmp) Map.t ]} ['cmp] is a phantom type uniquely identifying the comparison function, as generated by [Comparator.Make]. [Map.Poly] supports arbitrary key and value types, but enforces that the comparison function used to order the keys is polymorphic comparison. [Key.Map] has a fixed key type and comparison function, and supports arbitrary values. {[ type ('key, 'value) Map.Poly.t = ('key , 'value, Comparator.Poly.t) Map.t type 'value Key.Map.t = (Key.t, 'value, Key.comparator ) Map.t ]} The same map operations exist in [Map], [Map.Poly], and [Key.Map], albeit with different types. For example: {[ val Map.length : (_, _, _) Map.t -> int val Map.Poly.length : (_, _) Map.Poly.t -> int val Key.Map.length : _ Key.Map.t -> int ]} Because [Map.Poly.t] and [Key.Map.t] are exposed as instances of the more general [Map.t] type, one can use [Map.length] on any map. The same is true for all of the functions that access an existing map, such as [add], [change], [find], [fold], [iter], [map], [to_alist], etc. Depending on the number of type variables [N], the type of accessor (resp. creator) functions are defined in the module type [AccessorsN] (resp. [CreatorsN]) in {!Core_map_intf}. Also for creators, when the comparison function is not fixed, i.e. the ['cmp] variable of [Map.t] is free, we need to pass a comparator to the function creating the map. The module type is called [Creators3_with_comparator]. There is also a module type [Accessors3_with_comparator] in addition to [Accessors3] which used for trees since the comparator is not known. *) open Core_map_intf module Tree : sig type ('k, +'v, 'cmp) t with sexp_of include Creators_and_accessors3_with_comparator with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) t end type ('key, +'value, 'cmp) t (** Test if invariants of internal AVL search tree hold. *) val invariants : (_, _, _) t -> bool val comparator : ('a, _, 'cmp) t -> ('a, 'cmp) Comparator.t (** the empty map *) val empty : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t (** map with one key, data pair *) val singleton : comparator:('a, 'cmp) Comparator.t -> 'a -> 'b -> ('a, 'b, 'cmp) t (** creates map from association list with unique keys *) val of_alist : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> [ `Ok of ('a, 'b, 'cmp) t | `Duplicate_key of 'a ] (** creates map from association list with unique keys. Returns an error if duplicate 'a keys are found. *) val of_alist_or_error : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> ('a, 'b, 'cmp) t Or_error.t (** creates map from association list with unique keys. Raises an exception if duplicate 'a keys are found. *) val of_alist_exn : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> ('a, 'b, 'cmp) t (** creates map from association list with possibly repeated keys. *) val of_alist_multi : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> ('a, 'b list, 'cmp) t (** combines an association list into a map, folding together bound values with common keys *) val of_alist_fold : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> init:'c -> f:('c -> 'b -> 'c) -> ('a, 'c, 'cmp) t (** combines an association list into a map, reducing together bound values with common keys *) val of_alist_reduce : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> f:('b -> 'b -> 'b) -> ('a, 'b, 'cmp) t val to_tree : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) Tree.t (** Creates a [t] from a [Tree.t] and a [Comparator.t]. This is an O(n) operation as it must discover the length of the [Tree.t]. *) val of_tree : comparator:('k, 'cmp) Comparator.t -> ('k, 'v, 'cmp) Tree.t -> ('k, 'v, 'cmp) t (** creates map from sorted array of key-data pairs. The input array must be sorted, as given by the relevant comparator (either in ascending or descending order), and must not contain any duplicate keys. If either of these conditions do not hold, an error is returned. *) val of_sorted_array : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) array -> ('a, 'b, 'cmp) t Or_error.t (** Like [of_sorted_array] except behavior is undefined when an [Error] would have been returned. *) val of_sorted_array_unchecked : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) array -> ('a, 'b, 'cmp) t (** Test whether a map is empty or not. *) val is_empty : (_, _, _) t -> bool (** [length map] @return number of elements in [map]. O(1), but [Tree.length] is O(n). *) val length : (_, _, _) t -> int (** returns a new map with the specified new binding; if the key was already bound, its previous binding disappears. *) val add : ('k, 'v, 'cmp) t -> key:'k -> data:'v -> ('k, 'v, 'cmp) t (** if key is not present then add a singleton list, otherwise, cons data on the head of the existing list. *) val add_multi : ('k, 'v list, 'cmp) t -> key:'k -> data:'v -> ('k, 'v list, 'cmp) t (** [change map key f] updates the given map by changing the value stored under [key] according to [f]. Thus, for example, one might write: {[change m k (function None -> Some 0 | Some x -> Some (x + 1))]} to produce a new map where the integer stored under key [k] is incremented by one (treating an unknown key as zero). *) val change : ('k, 'v, 'cmp) t -> 'k -> ('v option -> 'v option) -> ('k, 'v, 'cmp) t (** returns the value bound to the given key, raising [Not_found] if none such exists *) val find : ('k, 'v, 'cmp) t -> 'k -> 'v option val find_exn : ('k, 'v, 'cmp) t -> 'k -> 'v (** returns a new map with any binding for the key in question removed *) val remove : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t (** [mem map key] tests whether [map] contains a binding for [key] *) val mem : ('k, _, 'cmp) t -> 'k -> bool (** iterator for map *) val iter : ('k, 'v, _) t -> f:(key:'k -> data:'v -> unit) -> unit (** Iterate two maps side by side. Complexity of this function is O(M+N). If two inputs are [(0, a); (1, a)] and [(1, b); (2, b)], [f] will be called with [(0, `Left a); (1, `Both (a, b)); (2, `Right b)] *) val iter2 : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:(key:'k -> data:[ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] -> unit) -> unit (** returns new map with bound values replaced by f applied to the bound values *) val map : ('k, 'v1, 'cmp) t -> f:('v1 -> 'v2) -> ('k, 'v2, 'cmp) t (** like [map], but function takes both key and data as arguments *) val mapi : ('k, 'v1, 'cmp) t -> f:(key:'k -> data:'v1 -> 'v2) -> ('k, 'v2, 'cmp) t (** folds over keys and data in map in increasing order of key. *) val fold : ('k, 'v, _) t -> init:'a -> f:(key:'k -> data:'v -> 'a -> 'a) -> 'a (** folds over keys and data in map in decreasing order of key. *) val fold_right : ('k, 'v, _) t -> init:'a -> f:(key:'k -> data:'v -> 'a -> 'a) -> 'a (** [filter], [filter_map], and [filter_mapi] run in O(n * lg n) time; they simply accumulate each key & data retained by [f] into a new map using [add]. *) val filter : ('k, 'v, 'cmp) t -> f:(key:'k -> data:'v -> bool) -> ('k, 'v, 'cmp) t (** returns new map with bound values filtered by f applied to the bound values *) val filter_map : ('k, 'v1, 'cmp) t -> f:('v1 -> 'v2 option) -> ('k, 'v2, 'cmp) t (** like [filter_map], but function takes both key and data as arguments*) val filter_mapi : ('k, 'v1, 'cmp) t -> f:(key:'k -> data:'v1 -> 'v2 option) -> ('k, 'v2, 'cmp) t (** Total ordering between maps. The first argument is a total ordering used to compare data associated with equal keys in the two maps. *) val compare_direct : ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are equal, that is, contain equal keys and associate them with equal data. [cmp] is the equality predicate used to compare the data associated with the keys. *) val equal : ('v -> 'v -> bool) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> bool (** returns list of keys in map *) val keys : ('k, _, _) t -> 'k list (** returns list of data in map *) val data : (_, 'v, _) t -> 'v list (** creates association list from map. No guarantee about order. *) val to_alist : ('k, 'v, _) t -> ('k * 'v) list val validate : name:('k -> string) -> 'v Validate.check -> ('k, 'v, _) t Validate.check (** {6 Additional operations on maps} *) (** merges two maps *) val merge : ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:(key:'k -> [ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] -> 'v3 option) -> ('k, 'v3, 'cmp) t (** [symmetric_diff t1 t2 ~data_equal] returns a list of changes between [t1] and [t2]. It is intended to be efficient in the case where [t1] and [t2] share a large amount of structure. *) val symmetric_diff : ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> data_equal:('v -> 'v -> bool) -> ('k * [ `Left of 'v | `Right of 'v | `Unequal of 'v * 'v ]) Sequence.t (** [min_elt map] @return Some [(key, data)] pair corresponding to the minimum key in [map], None if empty. *) val min_elt : ('k, 'v, _) t -> ('k * 'v) option val min_elt_exn : ('k, 'v, _) t -> 'k * 'v (** [max_elt map] @return Some [(key, data)] pair corresponding to the maximum key in [map], and None if [map] is empty. *) val max_elt : ('k, 'v, _) t -> ('k * 'v) option val max_elt_exn : ('k, 'v, _) t -> 'k * 'v (** same semantics as similar functions in List *) val for_all : ('k, 'v, _) t -> f:('v -> bool) -> bool val exists : ('k, 'v, _) t -> f:('v -> bool) -> bool (** [split t key] returns a map of keys strictly less than [key], the mapping of [key] if any, and a map of keys strictly greater than [key]. **) val split : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t * ('k * 'v) option * ('k, 'v, 'cmp) t (** [fold_range_inclusive t ~min ~max ~init ~f] folds f (with initial value ~init) over all keys (and their associated values) that are in the range [min, max] (inclusive). *) val fold_range_inclusive : ('k, 'v, 'cmp) t -> min:'k -> max:'k -> init:'a -> f:(key:'k -> data:'v -> 'a -> 'a) -> 'a (** [range_to_alist t ~min ~max] returns an associative list of the elements whose keys lie in [min, max] (inclusive), with the smallest key being at the head of the list. *) val range_to_alist : ('k, 'v, 'cmp) t -> min:'k -> max:'k -> ('k * 'v) list (** [closest_key t dir k] returns the [(key, value)] pair in [t] with [key] closest to [k], which satisfies the given inequality bound. For example, [closest_key t `Less_than k] would be the pair with the closest key to [k] where [key < k]. [to_sequence] can be used to get the same results as [closest_key]. It is less efficient for individual lookups but more efficient for finding many elements starting at some value. *) val closest_key : ('k, 'v, 'cmp) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'k -> ('k * 'v) option (** [nth t n] finds the (key, value) pair of rank n (i.e. such that there are exactly n keys strictly less than the found key), if one exists. O(log(length t) + n) time. *) val nth : ('k, 'v, _) t -> int -> ('k * 'v) option (** [rank t k] if k is in t, returns the number of keys strictly less than k in t, otherwise None *) val rank : ('k, 'v, 'cmp) t -> 'k -> int option (** [to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to t] gives a sequence of key-value pairs between [keys_less_or_equal_to] and [keys_greater_or_equal_to] inclusive, presented in [order]. If [keys_greater_or_equal_to > keys_less_or_equal_to], the sequence is empty. Cost is O(log n) up front and amortized O(1) to produce each element. *) val to_sequence : ?order : [ `Increasing_key (** default *) | `Decreasing_key ] -> ?keys_greater_or_equal_to : 'k -> ?keys_less_or_equal_to : 'k -> ('k, 'v, 'cmp) t -> ('k * 'v) Sequence.t module Poly : sig type ('a, +'b, 'c) map module Tree : sig type ('k, +'v) t = ('k, 'v, Comparator.Poly.comparator_witness) Tree.t with sexp include Creators_and_accessors2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) t end type ('a, +'b) t = ('a, 'b, Comparator.Poly.comparator_witness) map with bin_io, sexp, compare include Creators_and_accessors2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t end with type ('a, 'b, 'c) map = ('a, 'b, 'c) t module type Key = Key module type Key_binable = Key_binable module type S = S with type ('a, 'b, 'c) map := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t module type S_binable = S_binable with type ('a, 'b, 'c) map := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t module Make (Key : Key) : S with type Key.t = Key.t module Make_using_comparator (Key : sig type t with sexp include Comparator.S with type t := t end) : S with type Key.t = Key.t with type Key.comparator_witness = Key.comparator_witness module Make_binable (Key : Key_binable) : S_binable with type Key.t = Key.t module Make_binable_using_comparator (Key : sig type t with bin_io, sexp include Comparator.S with type t := t end) : S_binable with type Key.t = Key.t with type Key.comparator_witness = Key.comparator_witness core_kernel-113.00.00/src/core_map_bench.ml000066400000000000000000000013021256461164500203570ustar00rootroot00000000000000open Std open Core_map_intf BENCH_MODULE "Map.to_sequence" = struct let gen_test ~size ~from ~to_ = let map = List.init size ~f:(fun i -> string_of_int i, i) |> String.Map.of_alist_exn in fun () -> let seq = Map.to_sequence map ~keys_greater_or_equal_to:from ~keys_less_or_equal_to:to_ in Sequence.iter seq ~f:ignore BENCH_FUN "small-less" = gen_test ~size: 100 ~from:"45" ~to_:"55" BENCH_FUN "small-more" = gen_test ~size: 100 ~from: "5" ~to_:"95" BENCH_FUN "big-less" = gen_test ~size:1_000_000 ~from:"200000" ~to_:"200050" BENCH_FUN "big-more" = gen_test ~size:1_000_000 ~from:"20" ~to_:"900000" end core_kernel-113.00.00/src/core_map_intf.ml000066400000000000000000000667761256461164500202720ustar00rootroot00000000000000(** This module defines interfaces used in [Core.Std.Map]. See the documentation in core_map.mli for a description of the approach. CRs and comments about [Map] functions do not belong in this file. They belong next to the appropriate function in core_map.mli. This module defines module types [{Creators,Accessors}{1,2,3,_generic,_with_comparator}]. It uses check functors to ensure that each module types is an instance of the corresponding [_generic] one. We must treat [Creators] and [Accessors] separately, because we sometimes need to choose different instantiations of their [options]. In particular, [Map] itself matches [Creators3_with_comparator] but [Accessors3] (without comparator). *) open T module Binable = Binable0 module List = Core_list module type Key = sig type t with compare, sexp end module type Key_binable = sig type t with bin_io, compare, sexp end module Without_comparator = struct type ('key, 'cmp, 'z) t = 'z end module With_comparator = struct type ('key, 'cmp, 'z) t = comparator:('key, 'cmp) Comparator.t -> 'z end module type Accessors_generic = sig type ('a, 'b, 'cmp) t type ('a, 'b, 'cmp) tree type 'a key type ('a, 'cmp, 'z) options val invariants : ('k, 'cmp, ('k, 'v, 'cmp) t -> bool ) options val is_empty : (_, _, _) t -> bool val length : (_, _, _) t -> int val add : ('k, 'cmp, ('k, 'v, 'cmp) t -> key:'k key -> data:'v -> ('k, 'v, 'cmp) t ) options val add_multi : ('k, 'cmp, ('k, 'v list, 'cmp) t -> key:'k key -> data:'v -> ('k, 'v list, 'cmp) t ) options val change : ('k, 'cmp, ('k, 'v, 'cmp) t -> 'k key -> ('v option -> 'v option) -> ('k, 'v, 'cmp) t ) options val find : ('k, 'cmp, ('k, 'v, 'cmp) t -> 'k key -> 'v option) options val find_exn : ('k, 'cmp, ('k, 'v, 'cmp) t -> 'k key -> 'v ) options val remove : ('k, 'cmp, ('k, 'v, 'cmp) t -> 'k key -> ('k, 'v, 'cmp) t ) options val mem : ('k, 'cmp, ('k, _, 'cmp) t -> 'k key -> bool) options val iter : ('k, 'v, _) t -> f:(key:'k key -> data:'v -> unit) -> unit val iter2 : ('k, 'cmp, ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:(key:'k key -> data:[ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] -> unit) -> unit ) options val map : ('k, 'v1, 'cmp) t -> f:('v1 -> 'v2) -> ('k, 'v2, 'cmp) t val mapi : ('k, 'v1, 'cmp) t -> f:(key:'k key -> data:'v1 -> 'v2) -> ('k, 'v2, 'cmp) t val fold : ('k, 'v, _) t -> init:'a -> f:(key:'k key -> data:'v -> 'a -> 'a) -> 'a val fold_right : ('k, 'v, _) t -> init:'a -> f:(key:'k key -> data:'v -> 'a -> 'a) -> 'a val filter : ('k, 'cmp, ('k, 'v, 'cmp) t -> f:(key:'k key -> data:'v -> bool) -> ('k, 'v, 'cmp) t ) options val filter_map : ('k, 'cmp, ('k, 'v1, 'cmp) t -> f:('v1 -> 'v2 option) -> ('k, 'v2, 'cmp) t ) options val filter_mapi : ('k, 'cmp, ('k, 'v1, 'cmp) t -> f:(key:'k key -> data:'v1 -> 'v2 option) -> ('k, 'v2, 'cmp) t ) options val compare_direct : ('k, 'cmp, ('v -> 'v -> int) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> int ) options val equal : ('k, 'cmp, ('v -> 'v -> bool) -> ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> bool ) options val keys : ('k, _, _) t -> 'k key list val data : (_, 'v, _) t -> 'v list val to_alist : ('k, 'v, _) t -> ('k key * 'v) list val validate : name:('k key -> string) -> 'v Validate.check -> ('k, 'v, _) t Validate.check val merge : ('k, 'cmp, ('k, 'v1, 'cmp) t -> ('k, 'v2, 'cmp) t -> f:(key:'k key -> [ `Left of 'v1 | `Right of 'v2 | `Both of 'v1 * 'v2 ] -> 'v3 option) -> ('k, 'v3, 'cmp) t ) options val symmetric_diff : ('k, 'cmp, ('k, 'v, 'cmp) t -> ('k, 'v, 'cmp) t -> data_equal:('v -> 'v -> bool) -> ('k key * [ `Left of 'v | `Right of 'v | `Unequal of 'v * 'v ]) Sequence.t ) options val min_elt : ('k, 'v, _) t -> ('k key * 'v) option val min_elt_exn : ('k, 'v, _) t -> 'k key * 'v val max_elt : ('k, 'v, _) t -> ('k key * 'v) option val max_elt_exn : ('k, 'v, _) t -> 'k key * 'v val for_all : ('k, 'v, _) t -> f:('v -> bool) -> bool val exists : ('k, 'v, _) t -> f:('v -> bool) -> bool val split : ('k, 'cmp, ('k, 'v, 'cmp) t -> 'k key -> ('k, 'v, 'cmp) t * ('k key * 'v) option * ('k, 'v, 'cmp) t ) options val fold_range_inclusive : ('k, 'cmp, ('k, 'v, 'cmp) t -> min:'k key -> max:'k key -> init:'a -> f:(key:'k key -> data:'v -> 'a -> 'a) -> 'a ) options val range_to_alist : ('k, 'cmp, ('k, 'v, 'cmp) t -> min:'k key -> max:'k key -> ('k key * 'v) list ) options val closest_key : ('k, 'cmp, ('k, 'v, 'cmp) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'k key -> ('k key * 'v) option ) options val nth : ('k, 'cmp, ('k, 'v, 'cmp) t -> int -> ('k key * 'v) option ) options val rank : ('k, 'cmp, ('k, _, 'cmp) t -> 'k key -> int option ) options val to_tree : ('k, 'v, 'cmp) t -> ('k key, 'v, 'cmp) tree val to_sequence : ('k, 'cmp, ?order:[ `Increasing_key | `Decreasing_key ] -> ?keys_greater_or_equal_to:'k key -> ?keys_less_or_equal_to:'k key -> ('k, 'v, 'cmp) t -> ('k key * 'v) Sequence.t ) options end module type Accessors1 = sig type 'a t type 'a tree type key val invariants : _ t -> bool val is_empty : _ t -> bool val length : _ t -> int val add : 'a t -> key:key -> data:'a -> 'a t val add_multi : 'a list t -> key:key -> data:'a -> 'a list t val change : 'a t -> key -> ('a option -> 'a option) -> 'a t val find : 'a t -> key -> 'a option val find_exn : 'a t -> key -> 'a val remove : 'a t -> key -> 'a t val mem : _ t -> key -> bool val iter : 'a t -> f:(key:key -> data:'a -> unit) -> unit val iter2 : 'a t -> 'b t -> f:(key:key -> data:[ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] -> unit) -> unit val map : 'a t -> f:('a -> 'b) -> 'b t val mapi : 'a t -> f:(key:key -> data:'a -> 'b) -> 'b t val fold : 'a t -> init:'b -> f:(key:key -> data:'a -> 'b -> 'b) -> 'b val fold_right : 'a t -> init:'b -> f:(key:key -> data:'a -> 'b -> 'b) -> 'b val filter : 'a t -> f:(key:key -> data:'a -> bool) -> 'a t val filter_map : 'a t -> f:('a -> 'b option) -> 'b t val filter_mapi : 'a t -> f:(key:key -> data:'a -> 'b option) -> 'b t val compare_direct : ('a -> 'a -> int) -> 'a t -> 'a t -> int val equal : ('a -> 'a -> bool)-> 'a t -> 'a t -> bool val keys : _ t -> key list val data : 'a t -> 'a list val to_alist : 'a t -> (key * 'a) list val validate : name:(key -> string) -> 'a Validate.check -> 'a t Validate.check val merge : 'a t -> 'b t -> f:(key:key -> [ `Left of 'a | `Right of 'b | `Both of 'a * 'b ] -> 'c option) -> 'c t val symmetric_diff : 'a t -> 'a t -> data_equal:('a -> 'a -> bool) -> (key * [ `Left of 'a | `Right of 'a | `Unequal of 'a * 'a ]) Sequence.t val min_elt : 'a t -> (key * 'a) option val min_elt_exn : 'a t -> key * 'a val max_elt : 'a t -> (key * 'a) option val max_elt_exn : 'a t -> key * 'a val for_all : 'a t -> f:('a -> bool) -> bool val exists : 'a t -> f:('a -> bool) -> bool val split : 'a t -> key -> 'a t * (key * 'a) option * 'a t val fold_range_inclusive : 'a t -> min:key -> max:key -> init:'b -> f:(key:key -> data:'a -> 'b -> 'b) -> 'b val range_to_alist : 'a t -> min:key -> max:key -> (key * 'a) list val closest_key : 'a t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> key -> (key * 'a) option val nth : 'a t -> int -> (key * 'a) option val rank : _ t -> key -> int option val to_tree : 'a t -> 'a tree val to_sequence : ?order:[ `Increasing_key | `Decreasing_key ] -> ?keys_greater_or_equal_to:key -> ?keys_less_or_equal_to:key -> 'a t -> (key * 'a) Sequence.t end module type Accessors2 = sig type ('a, 'b) t type ('a, 'b) tree val invariants : (_, _) t -> bool val is_empty : (_, _) t -> bool val length : (_, _) t -> int val add : ('a, 'b) t -> key:'a -> data:'b -> ('a, 'b) t val add_multi : ('a, 'b list) t -> key:'a -> data:'b -> ('a, 'b list) t val change : ('a, 'b) t -> 'a -> ('b option -> 'b option) -> ('a, 'b) t val find : ('a, 'b) t -> 'a -> 'b option val find_exn : ('a, 'b) t -> 'a -> 'b val remove : ('a, 'b) t -> 'a -> ('a, 'b) t val mem : ('a, 'b) t -> 'a -> bool val iter : ('a, 'b) t -> f:(key:'a -> data:'b -> unit) -> unit val iter2 : ('a, 'b) t -> ('a, 'c) t -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> unit) -> unit val map : ('a, 'b) t -> f:('b -> 'c) -> ('a, 'c) t val mapi : ('a, 'b) t -> f:(key:'a -> data:'b -> 'c) -> ('a, 'c) t val fold : ('a, 'b) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val fold_right : ('a, 'b) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val filter : ('a, 'b) t -> f:(key:'a -> data:'b -> bool) -> ('a, 'b) t val filter_map : ('a, 'b) t -> f:('b -> 'c option) -> ('a, 'c) t val filter_mapi : ('a, 'b) t -> f:(key:'a -> data:'b -> 'c option) -> ('a, 'c) t val compare_direct : ('b -> 'b -> int) -> ('a, 'b) t -> ('a, 'b) t -> int val equal : ('b -> 'b -> bool)-> ('a, 'b) t -> ('a, 'b) t -> bool val keys : ('a, _) t -> 'a list val data : (_, 'b) t -> 'b list val to_alist : ('a, 'b) t -> ('a * 'b) list val validate : name:('a -> string) -> 'b Validate.check -> ('a, 'b) t Validate.check val merge : ('a, 'b) t -> ('a, 'c) t -> f:(key:'a -> [ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd option) -> ('a, 'd) t val symmetric_diff : ('a, 'b) t -> ('a, 'b) t -> data_equal:('b -> 'b -> bool) -> ('a * [ `Left of 'b | `Right of 'b | `Unequal of 'b * 'b ]) Sequence.t val min_elt : ('a, 'b) t -> ('a * 'b) option val min_elt_exn : ('a, 'b) t -> 'a * 'b val max_elt : ('a, 'b) t -> ('a * 'b) option val max_elt_exn : ('a, 'b) t -> 'a * 'b val for_all : (_, 'b) t -> f:('b -> bool) -> bool val exists : (_, 'b) t -> f:('b -> bool) -> bool val split : ('a, 'b) t -> 'a -> ('a, 'b) t * ('a * 'b) option * ('a, 'b) t val fold_range_inclusive : ('a, 'b) t -> min:'a -> max:'a -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val range_to_alist : ('a, 'b) t -> min:'a -> max:'a -> ('a * 'b) list val closest_key : ('a, 'b) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'a -> ('a * 'b) option val nth : ('a, 'b) t -> int -> ('a * 'b) option val rank : ('a, _) t -> 'a -> int option val to_tree : ('a, 'b) t -> ('a, 'b) tree val to_sequence : ?order:[ `Increasing_key | `Decreasing_key ] -> ?keys_greater_or_equal_to:'a -> ?keys_less_or_equal_to:'a -> ('a, 'b) t -> ('a * 'b) Sequence.t end module type Accessors3 = sig type ('a, 'b, 'cmp) t type ('a, 'b, 'cmp) tree val invariants : (_, _, _) t -> bool val is_empty : (_, _, _) t -> bool val length : (_, _, _) t -> int val add : ('a, 'b, 'cmp) t -> key:'a -> data:'b -> ('a, 'b, 'cmp) t val add_multi : ('a, 'b list, 'cmp) t -> key:'a -> data:'b -> ('a, 'b list, 'cmp) t val change : ('a, 'b, 'cmp) t -> 'a -> ('b option -> 'b option) -> ('a, 'b, 'cmp) t val find : ('a, 'b, 'cmp) t -> 'a -> 'b option val find_exn : ('a, 'b, 'cmp) t -> 'a -> 'b val remove : ('a, 'b, 'cmp) t -> 'a -> ('a, 'b, 'cmp) t val mem : ('a, 'b, 'cmp) t -> 'a -> bool val iter : ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> unit) -> unit val iter2 : ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> unit) -> unit val map : ('a, 'b, 'cmp) t -> f:('b -> 'c) -> ('a, 'c, 'cmp) t val mapi : ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> 'c) -> ('a, 'c, 'cmp) t val fold : ('a, 'b, _) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val fold_right : ('a, 'b, _) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val filter : ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> bool) -> ('a, 'b, 'cmp) t val filter_map : ('a, 'b, 'cmp) t -> f:('b -> 'c option) -> ('a, 'c, 'cmp) t val filter_mapi : ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> 'c option) -> ('a, 'c, 'cmp) t val compare_direct : ('b -> 'b -> int) -> ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) t -> int val equal : ('b -> 'b -> bool)-> ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) t -> bool val keys : ('a, _, _) t -> 'a list val data : (_, 'b, _) t -> 'b list val to_alist : ('a, 'b, _) t -> ('a * 'b) list val validate : name:('a -> string) -> 'b Validate.check -> ('a, 'b, _) t Validate.check val merge : ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t -> f:(key:'a -> [ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd option) -> ('a, 'd, 'cmp) t val symmetric_diff : ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) t -> data_equal:('b -> 'b -> bool) -> ('a * [ `Left of 'b | `Right of 'b | `Unequal of 'b * 'b ]) Sequence.t val min_elt : ('a, 'b, 'cmp) t -> ('a * 'b) option val min_elt_exn : ('a, 'b, 'cmp) t -> 'a * 'b val max_elt : ('a, 'b, 'cmp) t -> ('a * 'b) option val max_elt_exn : ('a, 'b, 'cmp) t -> 'a * 'b val for_all : (_, 'b, _) t -> f:('b -> bool) -> bool val exists : (_, 'b, _) t -> f:('b -> bool) -> bool val split : ('k, 'v, 'cmp) t -> 'k -> ('k, 'v, 'cmp) t * ('k * 'v) option * ('k, 'v, 'cmp) t val fold_range_inclusive : ('a, 'b, _) t -> min:'a -> max:'a -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val range_to_alist : ('a, 'b, _) t -> min:'a -> max:'a -> ('a * 'b) list val closest_key : ('a, 'b, _) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'a -> ('a * 'b) option val nth : ('a, 'b, _) t -> int -> ('a * 'b) option val rank : ('a, _, _) t -> 'a -> int option val to_tree : ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) tree val to_sequence : ?order:[ `Increasing_key | `Decreasing_key ] -> ?keys_greater_or_equal_to:'a -> ?keys_less_or_equal_to:'a -> ('a, 'b, _) t -> ('a * 'b) Sequence.t end module type Accessors3_with_comparator = sig type ('a, 'b, 'cmp) t type ('a, 'b, 'cmp) tree val invariants : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> bool val is_empty : ('a, 'b, 'cmp) t -> bool val length : ('a, 'b, 'cmp) t -> int val add : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> key:'a -> data:'b -> ('a, 'b, 'cmp) t val add_multi : comparator:('a, 'cmp) Comparator.t -> ('a, 'b list, 'cmp) t -> key:'a -> data:'b -> ('a, 'b list, 'cmp) t val change : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> 'a -> ('b option -> 'b option) -> ('a, 'b, 'cmp) t val find : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> 'a -> 'b option val find_exn : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> 'a -> 'b val remove : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> 'a -> ('a, 'b, 'cmp) t val mem : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> 'a -> bool val iter : ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> unit) -> unit val iter2 : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t -> f:(key:'a -> data:[ `Left of 'b | `Right of 'c | `Both of 'b * 'c ]-> unit) -> unit val map : ('a, 'b, 'cmp) t -> f:('b -> 'c) -> ('a, 'c, 'cmp) t val mapi : ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> 'c) -> ('a, 'c, 'cmp) t val fold : ('a, 'b, _) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val fold_right : ('a, 'b, _) t -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val filter : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> bool) -> ('a, 'b, 'cmp) t val filter_map : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> f:('b -> 'c option) -> ('a, 'c, 'cmp) t val filter_mapi : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> f:(key:'a -> data:'b -> 'c option) -> ('a, 'c, 'cmp) t val compare_direct : comparator:('a, 'cmp) Comparator.t -> ('b -> 'b -> int) -> ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) t -> int val equal : comparator:('a, 'cmp) Comparator.t -> ('b -> 'b -> bool) -> ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) t -> bool val keys : ('a, _, _) t -> 'a list val data : (_ , 'b, _) t -> 'b list val to_alist : ('a, 'b, _) t -> ('a * 'b) list val validate : name:('a -> string) -> 'b Validate.check -> ('a, 'b, _) t Validate.check val merge : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> ('a, 'c, 'cmp) t -> f:(key:'a -> [ `Left of 'b | `Right of 'c | `Both of 'b * 'c ] -> 'd option) -> ('a, 'd, 'cmp) t val symmetric_diff : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) t -> data_equal:('b -> 'b -> bool) -> ('a * [ `Left of 'b | `Right of 'b | `Unequal of 'b * 'b ]) Sequence.t val min_elt : ('a, 'b, 'cmp) t -> ('a * 'b) option val min_elt_exn : ('a, 'b, 'cmp) t -> 'a * 'b val max_elt : ('a, 'b, 'cmp) t -> ('a * 'b) option val max_elt_exn : ('a, 'b, 'cmp) t -> 'a * 'b val for_all : ('a, 'b, 'cmp) t -> f:('b -> bool) -> bool val exists : ('a, 'b, 'cmp) t -> f:('b -> bool) -> bool val split : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> 'a -> ('a, 'b, 'cmp) t * ('a * 'b) option * ('a, 'b, 'cmp) t val fold_range_inclusive : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> min:'a -> max:'a -> init:'c -> f:(key:'a -> data:'b -> 'c -> 'c) -> 'c val range_to_alist : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> min:'a -> max:'a -> ('a * 'b) list val closest_key : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> [ `Greater_or_equal_to | `Greater_than | `Less_or_equal_to | `Less_than ] -> 'a -> ('a * 'b) option val nth : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> int -> ('a * 'b) option val rank : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) t -> 'a -> int option val to_tree : ('a, 'b, 'cmp) t -> ('a, 'b, 'cmp) tree val to_sequence : comparator:('a, 'cmp) Comparator.t -> ?order:[ `Increasing_key | `Decreasing_key ] -> ?keys_greater_or_equal_to:'a -> ?keys_less_or_equal_to:'a -> ('a, 'b, 'cmp) t -> ('a * 'b) Sequence.t end (** Consistency checks (same as in [Container]). *) module Check_accessors (T : T3) (Tree : T3) (Key : T1) (Options : T3) (M : Accessors_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Options.t with type ('a, 'b, 'c) t := ('a, 'b, 'c) T.t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t with type 'a key := 'a Key.t) = struct end module Check_accessors1 (M : Accessors1) = Check_accessors (struct type ('a, 'b, 'c) t = 'b M.t end) (struct type ('a, 'b, 'c) t = 'b M.tree end) (struct type 'a t = M.key end) (Without_comparator) (M) module Check_accessors2 (M : Accessors2) = Check_accessors (struct type ('a, 'b, 'c) t = ('a, 'b) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (Without_comparator) (M) module Check_accessors3 (M : Accessors3) = Check_accessors (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.tree end) (struct type 'a t = 'a end) (Without_comparator) (M) module Check_accessors3_with_comparator (M : Accessors3_with_comparator) = Check_accessors (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.tree end) (struct type 'a t = 'a end) (With_comparator) (M) module type Creators_generic = sig type ('k, 'v, 'cmp) t type ('k, 'v, 'cmp) tree type 'k key type ('a, 'cmp, 'z) options val empty : ('k, 'cmp, ('k, _, 'cmp) t) options val singleton : ('k, 'cmp, 'k key -> 'v -> ('k, 'v, 'cmp) t) options val of_sorted_array : ('k, 'cmp, ('k key * 'v) array -> ('k, 'v, 'cmp) t Or_error.t) options val of_sorted_array_unchecked : ('k, 'cmp, ('k key * 'v) array -> ('k, 'v, 'cmp) t) options val of_alist : ('k, 'cmp, ('k key * 'v) list -> [ `Ok of ('k, 'v, 'cmp) t | `Duplicate_key of 'k key ] ) options val of_alist_or_error : ('k, 'cmp, ('k key * 'v) list -> ('k, 'v, 'cmp) t Or_error.t) options val of_alist_exn : ('k, 'cmp, ('k key * 'v) list -> ('k, 'v, 'cmp) t) options val of_alist_multi : ('k, 'cmp, ('k key * 'v) list -> ('k, 'v list, 'cmp) t) options val of_alist_fold : ('k, 'cmp, ('k key * 'v1) list -> init:'v2 -> f:('v2 -> 'v1 -> 'v2) -> ('k, 'v2, 'cmp) t ) options val of_alist_reduce : ('k, 'cmp, ('k key * 'v) list -> f:('v -> 'v -> 'v) -> ('k, 'v, 'cmp) t ) options val of_tree : ('k, 'cmp, ('k key, 'v, 'cmp) tree -> ('k, 'v, 'cmp) t ) options end module type Creators1 = sig type 'a t type 'a tree type key val empty : _ t val singleton : key -> 'a -> 'a t val of_alist : (key * 'a) list -> [ `Ok of 'a t | `Duplicate_key of key ] val of_alist_or_error : (key * 'a) list -> 'a t Or_error.t val of_alist_exn : (key * 'a) list -> 'a t val of_alist_multi : (key * 'a) list -> 'a list t val of_alist_fold : (key * 'a) list -> init:'b -> f:('b -> 'a -> 'b) -> 'b t val of_alist_reduce : (key * 'a) list -> f:('a -> 'a -> 'a) -> 'a t val of_sorted_array : (key * 'a) array -> 'a t Or_error.t val of_sorted_array_unchecked : (key * 'a) array -> 'a t val of_tree : 'a tree -> 'a t end module type Creators2 = sig type ('a, 'b) t type ('a, 'b) tree val empty : (_, _) t val singleton : 'a -> 'b -> ('a, 'b) t val of_alist : ('a * 'b) list -> [ `Ok of ('a, 'b) t | `Duplicate_key of 'a ] val of_alist_or_error : ('a * 'b) list -> ('a, 'b) t Or_error.t val of_alist_exn : ('a * 'b) list -> ('a, 'b) t val of_alist_multi : ('a * 'b) list -> ('a, 'b list) t val of_alist_fold : ('a * 'b) list -> init:'c -> f:('c -> 'b -> 'c) -> ('a, 'c) t val of_alist_reduce : ('a * 'b) list -> f:('b -> 'b -> 'b) -> ('a, 'b) t val of_sorted_array : ('a * 'b) array -> ('a, 'b) t Or_error.t val of_sorted_array_unchecked : ('a * 'b) array -> ('a, 'b) t val of_tree : ('a, 'b) tree -> ('a, 'b) t end module type Creators3_with_comparator = sig type ('a, 'b, 'cmp) t type ('a, 'b, 'cmp) tree val empty : comparator:('a, 'cmp) Comparator.t -> ('a, _, 'cmp) t val singleton : comparator:('a, 'cmp) Comparator.t -> 'a -> 'b -> ('a, 'b, 'cmp) t val of_alist : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> [ `Ok of ('a, 'b, 'cmp) t | `Duplicate_key of 'a ] val of_alist_or_error : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> ('a, 'b, 'cmp) t Or_error.t val of_alist_exn : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> ('a, 'b, 'cmp) t val of_alist_multi : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> ('a, 'b list, 'cmp) t val of_alist_fold : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> init:'c -> f:('c -> 'b -> 'c) -> ('a, 'c, 'cmp) t val of_alist_reduce : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) list -> f:('b -> 'b -> 'b) -> ('a, 'b, 'cmp) t val of_sorted_array : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) array -> ('a, 'b, 'cmp) t Or_error.t val of_sorted_array_unchecked : comparator:('a, 'cmp) Comparator.t -> ('a * 'b) array -> ('a, 'b, 'cmp) t val of_tree : comparator:('a, 'cmp) Comparator.t -> ('a, 'b, 'cmp) tree -> ('a, 'b, 'cmp) t end module Check_creators (T : T3) (Tree : T3) (Key : T1) (Options : T3) (M : Creators_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Options.t with type ('a, 'b, 'c) t := ('a, 'b, 'c) T.t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) Tree.t with type 'a key := 'a Key.t) = struct end module Check_creators1 (M : Creators1) = Check_creators (struct type ('a, 'b, 'c) t = 'b M.t end) (struct type ('a, 'b, 'c) t = 'b M.tree end) (struct type 'a t = M.key end) (Without_comparator) (M) module Check_creators2 (M : Creators2) = Check_creators (struct type ('a, 'b, 'c) t = ('a, 'b) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (Without_comparator) (M) module Check_creators3_with_comparator (M : Creators3_with_comparator) = Check_creators (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.t end) (struct type ('a, 'b, 'c) t = ('a, 'b, 'c) M.tree end) (struct type 'a t = 'a end) (With_comparator) (M) module type Creators_and_accessors_generic = sig include Creators_generic include Accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a key with type ('a, 'b, 'c) options := ('a, 'b, 'c) options end module type Creators_and_accessors1 = sig include Creators1 include Accessors1 with type 'a t := 'a t with type 'a tree := 'a tree with type key := key end module type Creators_and_accessors2 = sig include Creators2 include Accessors2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree end module type Creators_and_accessors3_with_comparator = sig include Creators3_with_comparator include Accessors3_with_comparator with type ('a, 'b, 'c) t := ('a, 'b, 'c) t with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree end module type S = sig type ('k, +'v, 'cmp) map type ('k, +'v, 'cmp) tree module Key : Comparator.S module Tree : sig type 'a t = (Key.t, 'a, Key.comparator_witness) tree with sexp include Creators_and_accessors1 with type 'a t := 'a t with type 'a tree := 'a t with type key := Key.t end type +'a t = (Key.t, 'a, Key.comparator_witness) map with compare, sexp include Creators_and_accessors1 with type 'a t := 'a t with type 'a tree := 'a Tree.t with type key := Key.t end module type S_binable = sig include S include Binable.S1 with type 'a t := 'a t end core_kernel-113.00.00/src/core_map_unit_tests.ml000066400000000000000000001072451256461164500215160ustar00rootroot00000000000000(* This module defines a functor, [Unit_tests], that does unit tests on a generic map, and then instantiates that functor to create unit tests for [Map], [Map.Poly], and [Int.Map]. *) module Caml_map = Map open Std open Core_map_intf module Unit_tests (Key : sig type 'a t with sexp val of_int : int -> int t val to_int : int t -> int end) (Map : sig type ('a, 'b, 'c) t_ type ('a, 'b, 'c) tree type ('a, 'b, 'c) create_options include Creators_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t_ with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a Key.t with type ('a, 'b, 'c) options := ('a, 'b, 'c) create_options val simplify_creator : (int, Int.comparator_witness, 'c) create_options -> 'c type ('a, 'b, 'c) access_options include Accessors_generic with type ('a, 'b, 'c) t := ('a, 'b, 'c) t_ with type ('a, 'b, 'c) tree := ('a, 'b, 'c) tree with type 'a key := 'a Key.t with type ('a, 'b, 'c) options := ('a, 'b, 'c) access_options val simplify_accessor : (int, Int.comparator_witness, 'c) access_options -> 'c val kind : [ `Map | `Tree ] end) (* The result signature doesn't actually mean anything -- the values are required so that implementors are reminded to add a unit test for each one. *) : Creators_and_accessors_generic = struct module Map = struct include Map let add x = simplify_accessor add x let add_multi x = simplify_accessor add_multi x let change x = simplify_accessor change x let find x = simplify_accessor find x let find_exn x = simplify_accessor find_exn x let invariants x = simplify_accessor invariants x let remove x = simplify_accessor remove x let mem x = simplify_accessor mem x let filter x = simplify_accessor filter x let filter_map x = simplify_accessor filter_map x let filter_mapi x = simplify_accessor filter_mapi x let compare_direct x = simplify_accessor compare_direct x let equal x = simplify_accessor equal x let iter2 x = simplify_accessor iter2 x let symmetric_diff x = simplify_accessor symmetric_diff x let merge x = simplify_accessor merge x let split x = simplify_accessor split x let fold_range_inclusive x = simplify_accessor fold_range_inclusive x let range_to_alist x = simplify_accessor range_to_alist x let closest_key x = simplify_accessor closest_key x let nth x = simplify_accessor nth x let rank x = simplify_accessor rank x let to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to x = simplify_accessor to_sequence ?order ?keys_greater_or_equal_to ?keys_less_or_equal_to x ;; let empty () = simplify_creator empty let singleton x = simplify_creator singleton x let of_sorted_array_unchecked x = simplify_creator of_sorted_array_unchecked x let of_sorted_array x = simplify_creator of_sorted_array x let of_alist x = simplify_creator of_alist x let of_alist_or_error x = simplify_creator of_alist_or_error x let of_alist_exn x = simplify_creator of_alist_exn x let of_alist_multi x = simplify_creator of_alist_multi x let of_alist_fold x = simplify_creator of_alist_fold x let of_alist_reduce x = simplify_creator of_alist_reduce x let of_tree x = simplify_creator of_tree x end type ('a, 'b, 'c) t = Unit_test_follows type ('a, 'b, 'c) tree = ('a, 'b, 'c) t type 'a key type ('a, 'b, 'c) options = ('a, 'b, 'c) Without_comparator.t module Key = struct open Key let of_int = of_int let to_int = to_int module T = struct type t = int Key.t with sexp let compare t t' = Pervasives.compare (to_int t) (to_int t') let equal t t' = compare t t' = 0 let (<) t t' = compare t t' < 0 let (>) t t' = compare t t' > 0 end include T let sample = of_int 0 let samples = List.init 10 ~f:(fun i -> of_int (i + 1)) |> List.dedup ~compare |> List.sort ~cmp:compare ;; let min = List.hd_exn samples let max = List.hd_exn (List.rev samples) let mid = List.nth_exn samples (List.length samples / 2) let pred t = of_int (to_int t - 1) let succ t = of_int (to_int t + 1) end module Caml_map = Caml_map.Make (Key) let random_alist keys = List.rev (List.fold keys ~init:[] ~f:(fun l key -> (key, Random.int 1000) :: l)) let random_map keys = List.fold (random_alist keys) ~init:(Map.empty ()) ~f:(fun map (key, data) -> Map.add ~key ~data map) let caml_map_of_alist alist = List.fold alist ~init:Caml_map.empty ~f:(fun map (key, data) -> Caml_map.add key data map) let alist_equal l1 l2 = List.equal l1 l2 ~equal:(fun (k1, d1) (k2, d2) -> Key.equal k1 k2 && d1 = d2) let caml_map_to_alist map = List.rev (Caml_map.fold (fun key data l -> (key, data) :: l) map []) (* relies on correctness of Map.to_alist *) let equal_maps ~caml_map map = Map.length map = Caml_map.cardinal caml_map && alist_equal (Map.to_alist map) (caml_map_to_alist caml_map) let add _ = assert false let remove _ = assert false let find _ = assert false let mem _ = assert false let iter _ = assert false let map _ = assert false let mapi _ = assert false let fold _ = assert false let equal _ = assert false let compare_direct _ = assert false (* runs a series of random tests on a map of the input type and a Caml map to see if they have the same behavior *) TEST = let rec loop n ~prev_caml_map ~caml_map ~prev_core_map ~core_map = if n = 0 then equal_maps ~caml_map core_map else let remove key = Caml_map.remove key caml_map, Map.remove core_map key in let add key = let data = Random.int 1000 in Caml_map.add key data caml_map, Map.add ~key ~data core_map in let caml_choose caml_map = try Some (Caml_map.choose caml_map) with _ -> None in let add_or_remove ~prefer = match caml_choose caml_map, prefer with | None, _ -> add Key.sample | Some (key, _), `Remove -> remove key | Some (key, _), `Add -> match List.find Key.samples ~f:(fun key -> not (Caml_map.mem key caml_map)) with | Some key -> add key | None -> remove key in let old_values = caml_map, core_map in let new_caml_map, new_core_map = match Random.int 7 with | 0 -> add_or_remove ~prefer:`Add | 1 -> add_or_remove ~prefer:`Remove | 2 -> begin match caml_choose caml_map with | None -> assert (Map.is_empty core_map); assert (Map.length core_map = 0) | Some (key, data) -> assert (Caml_map.find key caml_map = data); assert (not (Map.is_empty core_map)); assert (Map.length core_map = Caml_map.cardinal caml_map); assert (Map.mem core_map key); assert (Map.find core_map key = Some data) end; old_values | 3 -> let target = let sum = ref 0 in Caml_map.iter (fun _ data -> sum := !sum + data) caml_map; !sum in let actual = let sum = ref 0 in Map.iter ~f:(fun ~key:_ ~data -> sum := !sum + data) core_map; !sum in assert (target = actual); old_values | 4 -> let caml_map = Caml_map.mapi (fun key data -> (key, data)) caml_map in let core_map = Map.mapi ~f:(fun ~key ~data -> (key, data)) core_map in let increment = Random.int 1000 in let caml_map = Caml_map.map (fun (_, n) -> n + increment) caml_map in let core_map = Map.map ~f:(fun (_, n) -> n + increment) core_map in assert (equal_maps ~caml_map core_map); old_values | 5 -> let caml_alist = Caml_map.fold (fun key data acc -> (key, data) :: acc) caml_map [] in let core_alist = Map.fold ~f:(fun ~key ~data acc -> (key, data) :: acc) core_map ~init:[] in assert (alist_equal caml_alist core_alist); old_values | 6 -> let unchanged = Caml_map.equal (=) prev_caml_map caml_map in assert (unchanged = Map.equal (=) prev_core_map core_map); assert (unchanged = (Map.compare_direct Int.compare prev_core_map core_map = 0)); old_values | _ -> assert false in loop (n - 1) ~prev_caml_map:caml_map ~caml_map:new_caml_map ~prev_core_map:core_map ~core_map:new_core_map in loop 10000 ~prev_caml_map:Caml_map.empty ~caml_map:Caml_map.empty ~prev_core_map:(Map.empty ()) ~core_map:(Map.empty ()) ;; let iter2 _ = assert false TEST_UNIT = let test l1 l2 expected = let map_of_alist l = Map.of_alist_exn (List.map l ~f:(fun (k, v) -> Key.of_int k, v)) in let result = ref [] in Map.iter2 (map_of_alist l1) (map_of_alist l2) ~f:(fun ~key ~data -> result := (key, data) :: !result); let result = List.rev_map !result ~f:(fun (k, v) -> Key.to_int k, v) in assert (result = expected) in test [] [] []; test [0, 10] [] [0, `Left 10]; test [] [0, 10] [0, `Right 10]; test [0, 10] [0, 11] [0, `Both (10, 11)]; test [0, 10; 3, 13; 4, 14; 6, 16] [1, 11; 3, 13; 4, 14; 5, 15] [ 0, `Left 10 ; 1, `Right 11 ; 3, `Both (13, 13) ; 4, `Both (14, 14) ; 5, `Right 15 ; 6, `Left 16 ]; ;; let empty = Unit_test_follows TEST = equal_maps ~caml_map:Caml_map.empty (Map.empty ()) let singleton _ = assert false TEST = equal_maps ~caml_map:(Caml_map.add Key.sample 0 Caml_map.empty) (Map.singleton Key.sample 0) ;; let of_sorted_array _ = assert false (* test detection of invalid input *) TEST = Map.of_sorted_array [|Key.of_int 0, 0; Key.of_int 0, 0|] |! Result.is_error TEST = Map.of_sorted_array [|Key.of_int 1, 0 ; Key.of_int 0, 0 ; Key.of_int 1, 0|] |! Result.is_error let of_sorted_array_unchecked _ = assert false (* test it gets same result as [Map.of_alist] *) TEST = let alist = List.sort (random_alist Key.samples) ~cmp:(fun (k1, _) (k2, _) -> Key.compare k1 k2) in let array = Array.of_list alist in let array_rev = Array.of_list (List.rev alist) in let map_of_alist = Map.of_alist_exn alist in let map_of_array = Map.of_sorted_array_unchecked array in let map_of_rev_array = Map.of_sorted_array_unchecked array_rev in let map_equal = Map.equal Int.equal in map_equal map_of_alist map_of_array && map_equal map_of_alist map_of_rev_array ;; let invariants _ = assert false (* Test constructed AVL tree is valid *) TEST_UNIT = for n = 0 to 100 do let alist = List.init n ~f:(fun i -> Key.of_int i, i) in assert (List.permute alist |! Map.of_alist_exn |! Map.invariants); assert (Array.of_list alist |! Map.of_sorted_array_unchecked |! Map.invariants); assert (List.rev alist |! Array.of_list |! Map.of_sorted_array_unchecked |! Map.invariants); done ;; let of_alist _ = assert false TEST = let alist = random_alist Key.samples in match Map.of_alist alist with | `Duplicate_key _ -> false | `Ok map -> alist_equal (Map.to_alist map) alist ;; TEST = match Map.of_alist [] with | `Ok map -> Map.to_alist map = [] | `Duplicate_key _ -> false ;; TEST = match Map.of_alist [Key.sample, 0; Key.sample, 1] with | `Ok _ -> false | `Duplicate_key _ -> true ;; let of_alist_or_error _ = assert false TEST = Result.is_error (Map.of_alist_or_error [Key.sample, 0; Key.sample, 1]) TEST = Result.is_ok (Map.of_alist_or_error (List.map Key.samples ~f:(fun key -> (key,Key.to_int key)))) let of_alist_exn _ = assert false TEST = try ignore (Map.of_alist_exn [Key.sample, 0; Key.sample, 1]); false with _ -> true ;; let of_alist_fold _ = assert false let of_alist_reduce _ = assert false TEST_UNIT = let filtered = List.filter Key.samples ~f:(fun key -> not (Key.equal key Key.sample)) in let alist = random_alist filtered in let caml_map = Caml_map.add Key.sample 6 (caml_map_of_alist alist) in let alist' = (Key.sample, 1) :: (Key.sample, 2) :: alist @ [Key.sample, 3] in let core_map_fold = Map.of_alist_fold ~init:0 ~f:(+) alist' in let core_map_reduce = Map.of_alist_reduce ~f:(+) alist' in assert(equal_maps ~caml_map core_map_fold); assert(equal_maps ~caml_map core_map_reduce); ;; let of_alist_multi _ = assert false TEST = equal_maps ~caml_map:(Caml_map.add Key.sample [0; 1] Caml_map.empty) (Map.of_alist_multi [Key.sample, 0; Key.sample, 1]) ;; let is_empty _ = assert false TEST = Map.is_empty (Map.empty ()) TEST = not (Map.is_empty (Map.singleton Key.sample 0)) TEST = not (Map.is_empty (random_map Key.samples)) let of_tree _ = assert false let to_tree _ = assert false TEST = Map.is_empty (Map.of_tree (Map.to_tree (Map.empty ()))) TEST = let map = random_map Key.samples in alist_equal (Map.to_alist map) (Map.to_alist (Map.of_tree (Map.to_tree map))) ;; let add_multi _ = assert false TEST = let m1 = Map.add_multi (Map.empty ()) ~key:Key.sample ~data:0 in let m2 = Map.add_multi m1 ~key:Key.sample ~data:1 in equal_maps m2 ~caml_map:(Caml_map.add Key.sample [1; 0] Caml_map.empty) ;; let change _ = assert false TEST = let m1 = Map.remove (random_map Key.samples) Key.sample in let f = function Some x -> Some (x + 1) | None -> Some 0 in let m2 = Map.change m1 Key.sample f in let m3 = Map.change m2 Key.sample f in match Map.find m3 Key.sample with | Some 1 -> true | _ -> false ;; TEST = let m1 = Map.add (random_map Key.samples) ~key:Key.sample ~data:0 in let m2 = Map.change m1 Key.sample (function | Some _ -> None | None -> Some 0) in match Map.find m2 Key.sample with | None -> true | Some _ -> false ;; let find_exn _ = assert false TEST = try ignore (Map.find_exn (Map.empty ()) Key.sample); false with Not_found -> true ;; let fold_right _ = assert false TEST = let f ~key ~data acc = (key, data) :: acc in let map = random_map Key.samples in let alist = Map.fold map ~init:[] ~f in let right_alist = List.rev (Map.fold_right map ~init:[] ~f) in alist_equal right_alist alist ;; let filter _ = assert false TEST = let caml_map = Caml_map.add Key.sample 0 Caml_map.empty in let core_map = Map.filter (Map.add (random_map Key.samples) ~key:Key.sample ~data:0) ~f:(fun ~key ~data -> Key.equal key Key.sample && data = 0) in equal_maps ~caml_map core_map ;; let filter_map _ = assert false TEST = let alist = random_alist Key.samples in let core_map = Map.add (Map.of_alist_exn alist) ~key:Key.sample ~data:(-1) in let core_map = Map.filter_map core_map ~f:(fun x -> if x >= 0 then Some (x + 1) else None) in let caml_map = Caml_map.remove Key.sample (caml_map_of_alist alist) in let caml_map = Caml_map.map (fun x -> x + 1) caml_map in equal_maps ~caml_map core_map ;; let filter_mapi _ = assert false TEST = let base_map = Map.add (random_map Key.samples) ~key:Key.sample ~data:0 in let m1 = Map.filter_mapi base_map ~f:(fun ~key ~data -> if Key.equal key Key.sample && data = 0 then None else Some (data + 1)) in let m2 = Map.map (Map.remove base_map Key.sample) ~f:(fun x -> x + 1) in Map.equal (=) m1 m2 ;; let keys _ = assert false let data _ = assert false let to_alist _ = assert false TEST = let map = Map.of_alist_exn (random_alist Key.samples) in let map_keys = Map.keys map in let sorted_keys = List.sort map_keys ~cmp:Key.compare in List.equal map_keys sorted_keys ~equal:Key.equal ;; TEST_UNIT = let base_alist = random_alist Key.samples in let map = Map.of_alist_exn base_alist in let map_keys = Map.keys map in let all_keys = List.sort ~cmp:Key.compare Key.samples in let map_data = Map.data map in let map_alist = Map.to_alist map in assert (List.equal map_keys all_keys ~equal:Key.equal); assert (alist_equal map_alist base_alist); assert (alist_equal (List.zip_exn map_keys map_data) base_alist); ;; let symmetric_diff _ = assert false TEST = let m1 = random_map Key.samples in Sequence.to_list (Map.symmetric_diff m1 m1 ~data_equal:(=)) = [] ;; TEST = let key = Key.of_int 7 in let m1 = Map.empty () in let m1 = Map.add m1 ~key:(Key.of_int 1) ~data:1 in let m2 = Map.add m1 ~key:key ~data:2_000 in Sequence.to_list (Map.symmetric_diff m1 m2 ~data_equal:(=)) = [(key, `Right 2_000)] ;; TEST = let m1 = random_map Key.samples in let m2 = List.fold (Map.to_alist m1) ~init:(Map.empty ()) ~f:(fun m (k,d) -> Map.add m ~key:k ~data:d) in Sequence.to_list (Map.symmetric_diff m1 m2 ~data_equal:(=)) = [] ;; TEST = let key = Key.of_int 20 in let m1 = random_map Key.samples in let m2 = Map.add m1 ~key:key ~data:2_000 in Sequence.to_list (Map.symmetric_diff m1 m2 ~data_equal:(=)) = [(key, `Right 2_000)] ;; TEST = let key = Key.of_int 5 in let m1 = random_map Key.samples in let m2 = Map.remove m1 key in Sequence.to_list (Map.symmetric_diff m1 m2 ~data_equal:(=)) = [(key, `Left (Map.find_exn m1 key))] ;; TEST = let key = Key.of_int 7 in let m1 = random_map Key.samples in let m2 = Map.change m1 key (function | None -> assert false | Some v -> assert (v <> 2_000); Some 2_000) in Sequence.to_list (Map.symmetric_diff m1 m2 ~data_equal:(=)) = [(key, `Unequal (Map.find_exn m1 key, 2000))] ;; TEST = let map1 = Int.Map.empty in let map2 = Int.Map.of_alist_exn [ (1, 1) ; (2, 2) ; (3, 3) ; (4, 4) ; (5, 5) ] in let diff = Int.Map.symmetric_diff map1 map2 ~data_equal:Int.equal in Sequence.length diff = 5 ;; TEST = let map1 = Int.Map.of_alist_exn [ (1, 1) ; (2, 2) ; (3, 3) ; (4, 4) ; (5, 5) ] in let map2 = Int.Map.empty in let diff = Int.Map.symmetric_diff map1 map2 ~data_equal:Int.equal in Sequence.length diff = 5 ;; TEST = let map1 = Int.Map.of_alist_exn [ (1, 1) ; (2, 2) ] in let map2 = List.fold [ (3, 3) ; (4, 4) ; (5, 5) ] ~init:map1 ~f:(fun acc (key, data) -> Int.Map.add acc ~key ~data) in let diff = Int.Map.symmetric_diff map1 map2 ~data_equal:Int.equal in Sequence.length diff = 3 ;; TEST = let map2 = Int.Map.of_alist_exn [ (1, 1) ; (2, 2) ] in let map1 = List.fold [ (3, 3) ; (4, 4) ; (5, 5) ] ~init:map2 ~f:(fun acc (key, data) -> Int.Map.add acc ~key ~data) in let diff = Int.Map.symmetric_diff map1 map2 ~data_equal:Int.equal in Sequence.length diff = 3 ;; let merge _ = assert false TEST = let map = random_map Key.samples in let added_to_self = Map.merge map map ~f:(fun ~key:_ -> function | `Left _ | `Right _ -> assert false | `Both (x1, x2) -> Some (x1 + x2)) in let doubled = Map.map map ~f:(fun x -> x * 2) in Map.equal (=) added_to_self doubled ;; TEST = let map = random_map Key.samples in let map' = Map.merge map (Map.empty ()) ~f:(fun ~key:_ x -> match x with | `Right _ | `Both _ -> assert false | `Left x -> Some x) in Map.equal (=) map map' ;; TEST = let map = random_map Key.samples in let map' = Map.merge (Map.empty ()) map ~f:(fun ~key:_ x -> match x with | `Left _ | `Both _ -> assert false | `Right x -> Some x) in Map.equal (=) map map' ;; TEST = let map = random_map Key.samples in let map' = Map.merge map map ~f:(fun ~key:_ x -> match x with | `Left _ | `Right _ -> assert false | `Both _ -> None) in Map.is_empty map' ;; let min_and_max_keys ~init keys = List.fold keys ~init:(init, init) ~f:(fun (min, max) key -> ((if Key.compare key min < 0 then key else min), (if Key.compare key max > 0 then key else max))) let min_elt _ = assert false let min_elt_exn _ = assert false let max_elt _ = assert false let max_elt_exn _ = assert false TEST_UNIT = let min_key, max_key = min_and_max_keys ~init:Key.sample Key.samples in let map = random_map (Key.sample :: Key.samples) in let min_key_element = Map.find_exn map min_key in let max_key_element = Map.find_exn map max_key in assert (Map.max_elt_exn map = (max_key, max_key_element)); assert (Map.max_elt map = Some (max_key, max_key_element)); assert (Map.min_elt_exn map = (min_key, min_key_element)); assert (Map.min_elt map = Some (min_key, min_key_element)); ;; TEST = Map.min_elt (Map.empty ()) = None TEST = Map.max_elt (Map.empty ()) = None TEST = try ignore (Map.min_elt_exn (Map.empty ())); false with _ -> true TEST = try ignore (Map.max_elt_exn (Map.empty ())); false with _ -> true let for_all _ = assert false let exists _ = assert false TEST = Map.for_all (Map.empty ()) ~f:(fun _ -> assert false) TEST = not (Map.exists (Map.empty ()) ~f:(fun _ -> assert false)) TEST_UNIT = let pos x = x >= 0 in let neg x = x < 0 in let base_map = random_map Key.samples in let with_negative = Map.add base_map ~key:Key.sample ~data:(-1) in assert (Map.for_all base_map ~f:pos); assert (not (Map.for_all with_negative ~f:pos)); assert (not (Map.exists base_map ~f:neg)); assert (Map.exists with_negative ~f:neg); ;; let to_sequence ?order:_ ?keys_greater_or_equal_to:_ ?keys_less_or_equal_to:_ _ = assert false TEST_MODULE "to_sequence" = struct let m = random_map Key.samples let (<=>) observed expected = <:test_eq< (Key.t * int) list >> (Sequence.to_list observed) expected let limit_keys min max = List.filter ~f:(fun (key, _) -> key >= min && key <= max) TEST_UNIT = Map.to_sequence ~order:`Increasing_key m <=> Map.to_alist m TEST_UNIT = Map.to_sequence ~order:`Decreasing_key m <=> List.rev (Map.to_alist m) TEST_UNIT = Map.to_sequence ~order:`Increasing_key ~keys_greater_or_equal_to:Key.mid m <=> limit_keys Key.mid Key.max (Map.to_alist m) ;; TEST_UNIT = let keys_greater_or_equal_to, keys_less_or_equal_to = Key.mid, Key.pred Key.max in Map.to_sequence m ~order:`Increasing_key ~keys_greater_or_equal_to ~keys_less_or_equal_to <=> limit_keys keys_greater_or_equal_to keys_less_or_equal_to (Map.to_alist m) ;; TEST_UNIT = Map.to_sequence m ~order:`Increasing_key ~keys_less_or_equal_to:Key.mid <=> limit_keys Key.min Key.mid (Map.to_alist m) ;; TEST_UNIT = Map.to_sequence ~order:`Decreasing_key ~keys_less_or_equal_to:Key.mid m <=> limit_keys Key.min Key.mid (List.rev (Map.to_alist m)) ;; TEST_UNIT = let keys_greater_or_equal_to, keys_less_or_equal_to = Key.succ Key.min, Key.mid in Map.to_sequence m ~order:`Decreasing_key ~keys_greater_or_equal_to ~keys_less_or_equal_to <=> limit_keys keys_greater_or_equal_to keys_less_or_equal_to (List.rev (Map.to_alist m)) ;; TEST_UNIT = Map.to_sequence m ~order:`Decreasing_key ~keys_greater_or_equal_to:Key.mid <=> limit_keys Key.mid Key.max (List.rev (Map.to_alist m)) ;; TEST_UNIT = Map.to_sequence ~order:`Increasing_key (Map.empty ()) <=> [] TEST_UNIT = Map.to_sequence ~order:`Decreasing_key (Map.empty ()) <=> [] TEST_UNIT = Map.to_sequence ~order:`Increasing_key ~keys_greater_or_equal_to:(Key.succ Key.max) m <=> [] TEST_UNIT = Map.to_sequence ~order:`Decreasing_key ~keys_less_or_equal_to:(Key.pred Key.min) m <=> [] TEST_UNIT = Map.to_sequence ~order:`Increasing_key ~keys_less_or_equal_to:Key.min ~keys_greater_or_equal_to:Key.max m <=> [] end let length _ = assert false (* Length has to be updated correctly by many operations, which should be tested here. Some basic operations are already tested above. *) TEST_MODULE "length" = struct let sample_map = random_map Key.samples let k1 = List.nth_exn (Map.keys sample_map) 0 let k2 = List.nth_exn (Map.keys sample_map) 1 let k3 = List.nth_exn (Map.keys sample_map) 2 let k4 = List.nth_exn (Map.keys sample_map) 3 TEST "change" = let m = Map.add ~key:Key.sample ~data:1 (Map.empty ()) in assert (Map.length m = 1); let m = Map.change m Key.sample Fn.id in let caml_map = Caml_map.add Key.sample 1 Caml_map.empty in assert (equal_maps m ~caml_map); let m = Map.change (Map.empty ()) Key.sample (Fn.const (Some 1)) in assert (Map.length m = 1); let m = Map.change m Key.sample (Fn.const (Some 1)) in assert (Map.length m = 1); let m = Map.change m Key.sample (Fn.const None) in Map.length m = 0 TEST "filter" = let m' = Map.filter sample_map ~f:(fun ~key:x ~data:_ -> x <> k1 && x <> k2) in let m'' = Map.remove (Map.remove sample_map k1) k2 in assert (Map.length m' = Map.length m''); Map.length m' = Map.length sample_map - 2 TEST "of_alist_exn and of_alist_fold" = let expected_length = List.length Key.samples in let dup x = (x,x) in let m = Map.of_alist_exn (List.map Key.samples ~f:dup) in assert (Map.length m = List.length Key.samples); let alist = List.map (Key.samples @ Key.samples) ~f:dup in let m = Map.of_alist_fold alist ~init:Key.sample ~f:(fun x _ -> x) in Map.length m = expected_length TEST "merge" = let m1 = Map.of_alist_exn [k1, 1] in let m2 = Map.of_alist_exn [k2, 2] in let m' = Map.merge m1 m2 ~f:(fun ~key:_ -> function | `Both _ -> assert false | `Left x | `Right x -> Some x) in assert (Map.length m' = 2); let m3 = Map.of_alist_exn [k1, 2] in let m' = Map.merge m1 m3 ~f:(fun ~key:_ -> function | `Both (x,_) -> Some x | `Left _ | `Right _ -> assert false) in assert (Map.length m' = 1); let m' = Map.merge m1 m3 ~f:(fun ~key:_ -> function | `Both (_,_) -> None | `Left _ | `Right _ -> assert false) in assert (Map.length m' = 0); let m4 = Map.of_alist_exn [k1, 1; k2, 2; k3, 3] in let m5 = Map.of_alist_exn [k3, 99; k4, 4] in let m' = Map.merge m4 m5 ~f:(fun ~key:_ -> function | `Both (x,_) -> Some x | `Left x | `Right x -> Some x) in Map.length m' = 4 end let fold_range_inclusive _ = assert false let range_to_alist _ = assert false let closest_key _ = assert false let nth _ = assert false let rank _ = assert false TEST_UNIT = let map = random_map (Key.sample :: Key.samples) in let min_key, max_key = min_and_max_keys ~init:Key.sample Key.samples in let after_min, before_max = List.fold Key.samples ~init:(max_key, min_key) ~f:(fun (near_min, near_max) key -> ((if Key.compare key min_key > 0 && Key.compare key near_min < 0 then key else near_min), (if Key.compare key max_key < 0 && Key.compare key near_max > 0 then key else near_max))) in let keys_between ~min ~max = Map.fold_range_inclusive map ~min ~max ~f:(fun ~key:_ ~data:_ n -> n + 1) ~init:0 in let length = Map.length map in (* fold_range_inclusive *) assert (keys_between ~min:min_key ~max:max_key = length); assert (keys_between ~min:after_min ~max:before_max = length - 2); (* closest_key *) let prev_key t k = Map.closest_key t `Less_than k in let next_key t k = Map.closest_key t `Greater_than k in assert (prev_key map min_key = None); assert (next_key map max_key = None); let optional_key_equal key = function | None -> false | Some (key', _) -> Key.equal key key' in assert (optional_key_equal min_key (prev_key map after_min)); assert (optional_key_equal max_key (next_key map before_max)); assert (optional_key_equal min_key (Map.closest_key map `Less_or_equal_to min_key)); assert (optional_key_equal min_key (Map.closest_key map `Greater_or_equal_to min_key)); assert (optional_key_equal max_key (Map.closest_key map `Less_or_equal_to max_key)); assert (optional_key_equal max_key (Map.closest_key map `Greater_or_equal_to max_key)); assert (optional_key_equal after_min (Map.closest_key map `Less_or_equal_to after_min)); assert (optional_key_equal after_min (Map.closest_key map `Greater_or_equal_to after_min)); assert (optional_key_equal before_max (Map.closest_key map `Less_or_equal_to before_max)); assert (optional_key_equal before_max (Map.closest_key map `Greater_or_equal_to before_max)); begin let map_with_hole_after_min = Map.remove map after_min in assert (optional_key_equal min_key ( prev_key map_with_hole_after_min after_min)); assert (optional_key_equal min_key ( Map.closest_key map_with_hole_after_min `Less_or_equal_to after_min)); let map_with_hole_before_max = Map.remove map before_max in assert (optional_key_equal max_key ( next_key map_with_hole_before_max before_max)); assert (optional_key_equal max_key ( Map.closest_key map_with_hole_before_max `Greater_or_equal_to before_max)); end; (* range_to_alist *) assert (alist_equal (Map.range_to_alist ~min:min_key ~max:max_key map) (Map.to_alist map)); assert (alist_equal (Map.range_to_alist ~min:after_min ~max:before_max map) (Map.to_alist (Map.remove (Map.remove map min_key) max_key))); (* rank *) assert (Map.rank map min_key = Some 0); assert (Map.rank map after_min = Some 1); assert (Map.rank map before_max = Some (length - 2)); assert (Map.rank map max_key = Some (length - 1)); assert (Map.rank (Map.remove map Key.sample) Key.sample = None); (* nth *) assert (alist_equal (Map.to_alist map) (List.init (Map.length map) ~f:(Map.nth map) |> List.filter_opt)); assert (Option.is_none (Map.nth map (-1))); assert (Option.is_none (Map.nth map (Map.length map))); ;; let split _ = assert false TEST_UNIT = let check here map pivot = let l, maybe, r = Map.split map pivot in assert(Map.invariants l); assert(Map.invariants r); Map.iter l ~f:(fun ~key ~data:_ -> assert (Key.(<) key pivot)); Map.iter r ~f:(fun ~key ~data:_ -> assert (Key.(>) key pivot)); <:test_eq< (Key.t * int) option >> ~here:[ here ] (Option.map ~f:(fun d -> pivot, d) (Map.find map pivot)) maybe; <:test_eq< int >> ~here:[ here ] (Map.length map) (Map.length l + Map.length r + Option.length maybe); in let map = random_map Key.samples in check _here_ map Key.min; check _here_ map Key.max; check _here_ map Key.mid; let map = Map.remove map Key.mid in check _here_ map Key.mid ;; TEST = Map.closest_key (Map.empty ()) `Greater_or_equal_to Key.sample = None TEST = Map.closest_key (Map.empty ()) `Greater_than Key.sample = None TEST = Map.closest_key (Map.empty ()) `Less_or_equal_to Key.sample = None TEST = Map.closest_key (Map.empty ()) `Less_than Key.sample = None let validate ~name:_ _ = assert false TEST_UNIT = let validate expect map = expect (Validate.result (Map.validate ~name:(fun key -> Sexp.to_string (<:sexp_of< Key.t >> key)) (Validate.of_error (fun i -> if i mod 2 = 0 then Ok () else error "must be even" i <:sexp_of< int >>)) map)) in let is_ok = Result.is_ok in let is_error = Result.is_error in assert (validate is_ok (Map.empty ())); assert (validate is_ok (Map.of_alist_exn [ Key.of_int 0, 0 ])); assert (validate is_error (Map.of_alist_exn [ Key.of_int 0, 1 ])); assert (validate is_ok (Map.of_alist_exn [ Key.of_int 0, 0; Key.of_int 1, 0 ])); assert (validate is_error (Map.of_alist_exn [ Key.of_int 0, 0; Key.of_int 1, 1 ])); ;; (* Ensure polymorphic equality raises for maps. *) TEST_UNIT = match Map.kind with | `Tree -> () | `Map -> let ts = [ Map.empty (); Map.of_alist_exn [ Key.sample, 13 ] ] in List.iter ts ~f:(fun t1 -> List.iter ts ~f:(fun t2 -> assert (Result.is_error (Result.try_with (fun () -> Poly.equal t1 t2))))); ;; end module Key_int = struct type 'a t = int with sexp let of_int = Fn.id let to_int = Fn.id end module Key_poly = struct type 'a t = 'a with sexp let of_int = Fn.id let to_int = Fn.id end module Create_options_with_comparator = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) With_comparator.t let simplify_creator f = f ~comparator:Core_int.comparator end module Create_options_without_comparator = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) Without_comparator.t let simplify_creator = Fn.id end module Access_options_without_comparator = struct type ('a, 'b, 'c) access_options = ('a, 'b, 'c) Without_comparator.t let simplify_accessor = Fn.id end module Access_options_with_comparator = struct type ('a, 'b, 'c) access_options = ('a, 'b, 'c) With_comparator.t let simplify_accessor f = f ~comparator:Core_int.comparator end TEST_MODULE "Map" = Unit_tests (Key_poly) (struct include Map type ('a, 'b, 'c) t_ = ('a, 'b, 'c) t type ('a, 'b, 'c) tree = ('a, 'b, 'c) Tree.t include Create_options_with_comparator include Access_options_without_comparator let kind = `Map end) TEST_MODULE "Map.Poly" = Unit_tests (Key_poly) (struct include Map.Poly type ('a, 'b, 'c) t_ = ('a, 'b) t type ('a, 'b, 'c) tree = ('a, 'b) Tree.t include Create_options_without_comparator include Access_options_without_comparator let kind = `Map end) TEST_MODULE "Int.Map" = Unit_tests (Key_int) (struct include Int.Map type ('a, 'b, 'c) t_ = 'b t type ('a, 'b, 'c) tree = 'b Tree.t include Create_options_without_comparator include Access_options_without_comparator let kind = `Map end) TEST_MODULE "Map.Tree" = Unit_tests (Key_poly) (struct include Map.Tree type ('a, 'b, 'c) t_ = ('a, 'b, 'c) t type ('a, 'b, 'c) tree = ('a, 'b, 'c) t include Create_options_with_comparator include Access_options_with_comparator let kind = `Tree end) TEST_MODULE "Map.Poly.Tree" = Unit_tests (Key_poly) (struct include Map.Poly.Tree type ('a, 'b, 'c) t_ = ('a, 'b) t type ('a, 'b, 'c) tree = ('a, 'b) t include Create_options_without_comparator include Access_options_without_comparator let kind = `Tree end) TEST_MODULE "Int.Map.Tree" = Unit_tests (Key_int) (struct include Int.Map.Tree type ('a, 'b, 'c) t_ = 'b t type ('a, 'b, 'c) tree = 'b t include Create_options_without_comparator include Access_options_without_comparator let kind = `Tree end) core_kernel-113.00.00/src/core_map_unit_tests.mli000066400000000000000000000000561256461164500216570ustar00rootroot00000000000000(* Unit test interface intentionally blank *) core_kernel-113.00.00/src/core_nativeint.ml000066400000000000000000000064241256461164500204560ustar00rootroot00000000000000open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std open Nativeint module T = struct type t = nativeint with sexp, bin_io, typerep let compare (x : t) y = compare x y let equal (x : t) y = x = y let hash (x : t) = Hashtbl.hash x let to_string = to_string let of_string = of_string end include T let num_bits = Word_size.num_bits Word_size.word_size let shift_right_logical = shift_right_logical let shift_right = shift_right let shift_left = shift_left let bit_not = lognot let bit_xor = logxor let bit_or = logor let bit_and = logand let min_value = min_int let max_value = max_int let abs = abs let pred = pred let succ = succ let rem = rem let neg = neg let minus_one = minus_one let one = one let zero = zero let to_float = to_float let of_float = of_float include Comparable.Validate_with_zero (struct include T let zero = zero end) module Replace_polymorphic_compare = struct let equal = equal let compare = compare let ascending = compare let descending x y = compare y x let min (x : t) y = if x < y then x else y let max (x : t) y = if x > y then x else y let ( >= ) (x : t) y = x >= y let ( <= ) (x : t) y = x <= y let ( = ) (x : t) y = x = y let ( > ) (x : t) y = x > y let ( < ) (x : t) y = x < y let ( <> ) (x : t) y = x <> y let between t ~low ~high = low <= t && t <= high let _squelch_unused_module_warning_ = () end include Replace_polymorphic_compare include Hashable.Make_binable (T) include Comparable.Map_and_set_binable (T) let ( / ) = div let ( * ) = mul let ( - ) = sub let ( + ) = add let ( ~- ) = neg let incr r = r := !r + one let decr r = r := !r - one let of_nativeint t = t let of_nativeint_exn = of_nativeint let to_nativeint t = t let to_nativeint_exn = to_nativeint module Conv = Int_conversions let of_int = Conv.int_to_nativeint let of_int_exn = of_int let to_int = Conv.nativeint_to_int let to_int_exn = Conv.nativeint_to_int_exn let of_int32 = Conv.int32_to_nativeint let of_int32_exn = of_int32 let to_int32 = Conv.nativeint_to_int32 let to_int32_exn = Conv.nativeint_to_int32_exn let of_int64 = Conv.int64_to_nativeint let of_int64_exn = Conv.int64_to_nativeint_exn let to_int64 = Conv.nativeint_to_int64 let pow b e = of_int_exn (Int_math.int_pow (to_int_exn b) (to_int_exn e)) include Conv.Make (T) include Conv.Make_hex(struct type t = nativeint with bin_io, compare, typerep let zero = zero let neg = (~-) let (<) = (<) let to_string i = Printf.sprintf "%nx" i let of_string s = Scanf.sscanf s "%nx" Fn.id let module_name = "Core_kernel.Std.Nativeint.Hex" end) include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Core_kernel.Std.Nativeint" end) module Pre_O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( ~- ) = ( ~- ) include (Replace_polymorphic_compare : Polymorphic_compare_intf.Infix with type t := t) let abs = abs let neg = neg let zero = zero let of_int_exn = of_int_exn end module O = struct include Pre_O include Int_math.Make (struct type nonrec t = t include Pre_O let rem = rem let to_float = to_float let of_float = of_float let of_string = T.of_string let to_string = T.to_string end) end include O (* [Nativeint] and [Nativeint.O] agree value-wise *) core_kernel-113.00.00/src/core_nativeint.mli000066400000000000000000000004671256461164500206300ustar00rootroot00000000000000include Int_intf.S with type t = nativeint val of_int : int -> t val to_int : t -> int option val to_int_exn : t -> int val of_int32 : int32 -> t val to_int32 : t -> int32 option val to_int32_exn : t -> int32 val of_int64 : int64 -> t option val of_nativeint : nativeint -> t val to_nativeint : t -> nativeint core_kernel-113.00.00/src/core_params.h000066400000000000000000000002321256461164500175460ustar00rootroot00000000000000#ifndef PARAMS_H #define PARAMS_H /* I/O transaction size after which to release the OCaml-lock */ #define THREAD_IO_CUTOFF 65536 #endif /* PARAMS_H */ core_kernel-113.00.00/src/core_printexc.ml000066400000000000000000000005711256461164500203060ustar00rootroot00000000000000let to_string _ = `Deprecated_use_Exn_to_string_instead let print _ = `Deprecated_use_Exn_to_string_instead let catch _ _ = `Deprecated_use_Exn_handle_uncaught_instead let print_backtrace = Caml.Printexc.print_backtrace let get_backtrace = Caml.Printexc.get_backtrace let record_backtrace = Caml.Printexc.record_backtrace let backtrace_status = Caml.Printexc.backtrace_status core_kernel-113.00.00/src/core_printexc.mli000066400000000000000000000007111256461164500204530ustar00rootroot00000000000000(** This module is here to ensure that we don't use the functions in [Caml.Printexc] inadvertently *) val to_string : exn -> [`Deprecated_use_Exn_to_string_instead] val print : exn -> [`Deprecated_use_Exn_to_string_instead] val catch : ('a -> _) -> 'a -> [`Deprecated_use_Exn_handle_uncaught_instead] val print_backtrace : out_channel -> unit val get_backtrace : unit -> string val record_backtrace : bool -> unit val backtrace_status : unit -> bool core_kernel-113.00.00/src/core_printf.ml000066400000000000000000000005171256461164500177540ustar00rootroot00000000000000include Printf (** failwith, invalid_arg, and exit accepting printf's format. *) let failwithf fmt = ksprintf (fun s () -> failwith s) fmt let invalid_argf fmt = ksprintf (fun s () -> invalid_arg s) fmt let exitf fmt = ksprintf (fun s () -> Printf.eprintf "%s\n%!" s; exit 1) fmt core_kernel-113.00.00/src/core_printf.mli000066400000000000000000000032341256461164500201240ustar00rootroot00000000000000 val fprintf : out_channel -> ('r, out_channel, unit) format -> 'r val printf : ('r, out_channel, unit) format -> 'r val eprintf : ('r, out_channel, unit) format -> 'r val ifprintf : 'a -> ('r, 'a, unit) format -> 'r val sprintf : ('r, unit, string) format -> 'r val bprintf : Buffer.t -> ('r, Buffer.t, unit) format -> 'r val kfprintf : (out_channel -> 'a) -> out_channel -> ('r, out_channel, unit, 'a) format4 -> 'r val ksprintf : (string -> 'a) -> ('r, unit, string, 'a) format4 -> 'r val kbprintf : (Buffer.t -> 'a) -> Buffer.t -> ('r, Buffer.t, unit, 'a) format4 -> 'r (** {6 Formatting error and exit functions} These functions have polymorphic return type, since they do not return. Naively, this doesn't mix well with variadic functions: if you define, say, {[ let f fmt = ksprintf (fun s -> failwith s) fmt ]} then you find that [f "%d" : int -> 'a], as you'd expect, and [f "%d" 7 : 'a]. The problem with this is that ['a] unifies with (say) [int -> 'b], so [f "%d" 7 4] is not a type error -- the [4] is simply ignored. To mitigate this problem, these functions all take a final unit parameter. These rarely arise as formatting positional parameters (they can do with e.g. "%a", but not in a useful way) so they serve as an effective signpost for "end of formatting arguments". *) (** raises Failure *) val failwithf : ('r, unit, string, unit -> _) format4 -> 'r (** raises Invalid_arg *) val invalid_argf : ('r, unit, string, unit -> _) format4 -> 'r (** print to stderr; exit 1 *) val exitf : ('r, unit, string, unit -> _) format4 -> 'r core_kernel-113.00.00/src/core_queue.ml000066400000000000000000000260321256461164500175760ustar00rootroot00000000000000open Common open Sexplib.Conv open Int_replace_polymorphic_compare module Sexp = Core_sexp module List = Core_list module Array = Core_array module Int = Core_int (* [t] stores the [t.length] queue elements at consecutive increasing indices of [t.elts], mod the capacity of [t], which is [Array.length t.elts]. The capacity is required to be a power of two (user-requested capacities are rounded up to the nearest power), so that mod can quickly be computed using [land t.mask], where [t.mask = capacity t - 1]. So, queue element [i] is at [t.elts.( (t.front + i) land t.mask )]. [num_mutations] is used to detect modification during iteration. *) type 'a t = { mutable num_mutations : int ; mutable front : int ; mutable mask : int ; mutable length : int ; mutable elts : 'a array } with fields, sexp_of let inc_num_mutations t = t.num_mutations <- t.num_mutations + 1 let capacity t = t.mask + 1 let dummy (type a) (_ : a t) = (Obj.magic None : a) let elts_index t i = (t.front + i) land t.mask let unsafe_get t i = Array.unsafe_get t.elts (elts_index t i) let unsafe_set t i a = Array.unsafe_set t.elts (elts_index t i) a let check_index_exn t i = if i < 0 || i >= t.length then failwiths "Queue index out of bounds" (i, `length t.length) <:sexp_of< int * [ `length of int ] >> ;; let get t i = check_index_exn t i; unsafe_get t i let set t i a = check_index_exn t i; inc_num_mutations t; unsafe_set t i a; ;; let is_empty t = t.length = 0 let ensure_no_mutation t num_mutations = if t.num_mutations <> num_mutations then failwiths "mutation of queue during iteration" t <:sexp_of< _ t >>; ;; let compare = let rec unsafe_compare_from compare_elt pos ~t1 ~t2 ~len1 ~len2 ~mut1 ~mut2 = match pos = len1, pos = len2 with | true , true -> 0 | true , false -> -1 | false, true -> 1 | false, false -> let x = compare_elt (unsafe_get t1 pos) (unsafe_get t2 pos) in ensure_no_mutation t1 mut1; ensure_no_mutation t2 mut2; match x with | 0 -> unsafe_compare_from compare_elt (pos + 1) ~t1 ~t2 ~len1 ~len2 ~mut1 ~mut2 | n -> n in fun compare_elt t1 t2 -> if phys_equal t1 t2 then 0 else unsafe_compare_from compare_elt 0 ~t1 ~t2 ~len1:(length t1) ~len2:(length t2) ~mut1:t1.num_mutations ~mut2:t2.num_mutations ;; let equal = let rec unsafe_equal_from equal_elt pos ~t1 ~t2 ~mut1 ~mut2 ~len = pos = len || (let b = equal_elt (unsafe_get t1 pos) (unsafe_get t2 pos) in ensure_no_mutation t1 mut1; ensure_no_mutation t2 mut2; b && unsafe_equal_from equal_elt (pos + 1) ~t1 ~t2 ~mut1 ~mut2 ~len) in fun equal_elt t1 t2 -> phys_equal t1 t2 || (let len1 = length t1 in let len2 = length t2 in len1 = len2 && unsafe_equal_from equal_elt 0 ~t1 ~t2 ~len:len1 ~mut1:t1.num_mutations ~mut2:t2.num_mutations) ;; let invariant invariant_a t = Invariant.invariant _here_ t <:sexp_of< _ t >> (fun () -> let check f = Invariant.check_field t f in Fields.iter ~num_mutations:ignore ~front:(check (fun front -> assert (front >= 0); assert (front < capacity t))) ~mask:(check (fun _ -> let capacity = capacity t in assert (capacity = Array.length t.elts); assert (capacity >= 1); assert (Int.is_pow2 capacity))) ~length:(check (fun length -> assert (length >= 0); assert (length <= capacity t))) ~elts:(check (fun _ -> let num_mutations = t.num_mutations in for i = 0 to capacity t - 1 do let elt = unsafe_get t i in if i < t.length then (invariant_a elt; ensure_no_mutation t num_mutations) else assert (phys_equal elt (dummy t)) done))) ;; let create (type a) ?capacity () : a t = let capacity = match capacity with | None -> 1 | Some capacity -> if capacity < 0 then failwiths "cannot have queue with negative capacity" capacity <:sexp_of< int >> else if capacity = 0 then 1 else Int.ceil_pow2 capacity in { num_mutations = 0 ; front = 0 ; mask = capacity - 1 ; length = 0 ; elts = Array.create ~len:capacity (Obj.magic None : a) } ;; let blit_to_array ~src dst = assert (src.length <= Array.length dst); let front_len = Int.min src.length (capacity src - src.front) in let rest_len = src.length - front_len in Array.blit ~len:front_len ~src:src.elts ~src_pos:src.front ~dst ~dst_pos:0; Array.blit ~len:rest_len ~src:src.elts ~src_pos:0 ~dst ~dst_pos:front_len; ;; let set_capacity t desired_capacity = (* We allow arguments less than 1 to [set_capacity], but translate them to 1 to simplify the code that relies on the array length being a power of 2. *) inc_num_mutations t; let new_capacity = Int.ceil_pow2 (max 1 (max desired_capacity t.length)) in if new_capacity <> capacity t then begin let dst = Array.create ~len:new_capacity (dummy t) in blit_to_array ~src:t dst; t.front <- 0; t.mask <- new_capacity - 1; t.elts <- dst; end; ;; let enqueue t a = inc_num_mutations t; if t.length = capacity t then set_capacity t (2 * t.length); unsafe_set t t.length a; t.length <- t.length + 1; ;; let dequeue_nonempty t = inc_num_mutations t; let elts = t.elts in let front = t.front in let res = elts.( front ) in elts.( front ) <- dummy t; t.front <- elts_index t 1; t.length <- t.length - 1; res ;; let dequeue_exn t = if is_empty t then raise Caml.Queue.Empty else dequeue_nonempty t ;; let dequeue t = if is_empty t then None else Some (dequeue_nonempty t) ;; let peek_nonempty t = Array.unsafe_get t.elts t.front let peek t = if is_empty t then None else Some (peek_nonempty t) ;; let peek_exn t = if is_empty t then raise Caml.Queue.Empty else peek_nonempty t ;; let clear t = inc_num_mutations t; if length t > 0 then begin for i = 0 to t.length - 1 do unsafe_set t i (dummy t); done; t.length <- 0; t.front <- 0; end; ;; let blit_transfer ~src ~dst ?len () = inc_num_mutations src; inc_num_mutations dst; let len = match len with | None -> length src | Some len -> if len < 0 then failwiths "Queue.blit_transfer: negative length" len <:sexp_of< int >>; min len (length src) in if len > 0 then begin set_capacity dst (max (capacity dst) (dst.length + len)); let dst_start = dst.front + dst.length in for i = 0 to len - 1 do (* This is significantly faster than simply [enqueue dst (dequeue_nonempty src)] *) let src_i = (src.front + i) land src.mask in let dst_i = (dst_start + i) land dst.mask in Array.unsafe_set dst.elts dst_i (Array.unsafe_get src.elts src_i); Array.unsafe_set src.elts src_i (dummy src); done; dst.length <- dst.length + len; src.front <- (src.front + len) land src.mask; src.length <- src.length - len; end; ;; let fold t ~init ~f = if t.length = 0 then init else begin let num_mutations = t.num_mutations in let r = ref init in for i = 0 to t.length - 1 do r := f !r (unsafe_get t i); ensure_no_mutation t num_mutations; done; !r end; ;; (* [iter] is implemented directly because implementing it in terms of fold is slower *) let iter t ~f = let num_mutations = t.num_mutations in for i = 0 to t.length - 1 do f (unsafe_get t i); ensure_no_mutation t num_mutations; done; ;; module C = Container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter end) let to_list = C.to_list let count = C.count let sum = C.sum let find = C.find let find_map = C.find_map let exists = C.exists let for_all = C.for_all let mem = C.mem let min_elt = C.min_elt let max_elt = C.max_elt (* For [concat_map], [filter_map], and [filter], we don't create [t_result] with [t]'s capacity because we have no idea how many elements [t_result] will ultimately hold. *) let concat_map t ~f = let t_result = create () in iter t ~f:(fun a -> List.iter (f a) ~f:(fun b -> enqueue t_result b)); t_result ;; let filter_map t ~f = let t_result = create () in iter t ~f:(fun a -> match f a with | None -> () | Some b -> enqueue t_result b); t_result ;; let filter t ~f = let t_result = create () in iter t ~f:(fun a -> if f a then enqueue t_result a); t_result ;; let filter_inplace t ~f = let t2 = filter t ~f in clear t; blit_transfer ~src:t2 ~dst:t (); ;; let copy src = let dst = create ~capacity:src.length () in blit_to_array ~src dst.elts; dst.length <- src.length; dst ;; let of_list l = (* Traversing the list up front to compute its length is probably (but not definitely) better than doubling the underlying array size several times for large queues. *) let t = create ~capacity:(List.length l) () in List.iter l ~f:(fun x -> enqueue t x); t ;; (* The queue [t] returned by [create] will have [t.length = 0], [t.front = 0], and [capacity t = Int.ceil_pow2 len]. So, we only have to set [t.length] to [len] after the blit to maintain all the invariants: [t.length] is equal to the number of elements in the queue, [t.front] is the array index of the first element in the queue, and [capacity t = Array.length t.elts]. *) let of_array a = let len = Array.length a in let t = create ~capacity:len () in Array.blit ~len ~src:a ~src_pos:0 ~dst:t.elts ~dst_pos:0; t.length <- len; t ;; let to_array t = Array.init t.length ~f:(fun i -> unsafe_get t i) let map ta ~f = let num_mutations = ta.num_mutations in let tb = create ~capacity:ta.length () in tb.length <- ta.length; for i = 0 to ta.length - 1 do let b = f (unsafe_get ta i) in ensure_no_mutation ta num_mutations; Array.unsafe_set tb.elts i b; done; tb ;; let singleton x = let t = create () in enqueue t x; t ;; let sexp_of_t sexp_of_a t = to_list t |> <:sexp_of< a list >> let t_of_sexp a_of_sexp sexp = sexp |> <:of_sexp< a list >> |> of_list include Bin_prot.Utils.Make_iterable_binable1 (struct type nonrec 'a t = 'a t type 'a el = 'a with bin_io type 'a acc = 'a t let module_name = Some "Core.Queue" let length = length let iter = iter let init n = create ~capacity:n () let insert t x _ = enqueue t x; t let finish = Fn.id end) include Binary_searchable.Make1 (struct type nonrec 'a t = 'a t let get = get let length = length module For_test = struct let of_array a = let r = create () in (* We enqueue everything twice, and dequeue it once to ensure: - that the queue has the same content as the array. - that it has, in most cases, an interesting internal structure*) for i = 0 to Core_array.length a - 1 do enqueue r a.( i ) done; for i = 0 to Core_array.length a - 1 do ignore (dequeue_exn r : bool); enqueue r a.( i ) done; r end end) core_kernel-113.00.00/src/core_queue.mli000066400000000000000000000063511256461164500177510ustar00rootroot00000000000000(** A queue implemented with an array. The implementation will grow the array as necessary. The array will never automatically be shrunk, but the size can be interrogated and set with [capacity] and [set_capacity]. Iteration functions ([iter], [fold], [map], [concat_map], [filter], [filter_map], [filter_inplace], and some functions from [Container.S1]) will raise if the queue is modified during iteration. Differences from the standard module: [enqueue] replaces [push] and [add], and takes the queue first. [dequeue] replaces [pop] and [take], and returns an option rather than raising [Empty]. [dequeue_exn] is available if you want to raise [Empty]. [iter] and [fold] take labeled arguments. [blit_transfer] replaces [transfer] but is markedly different; see below. *) type 'a t with bin_io, compare, sexp include Binary_searchable.S1 with type 'a t := 'a t include Container. S1 with type 'a t := 'a t include Equal. S1 with type 'a t := 'a t include Invariant. S1 with type 'a t := 'a t (** Create an empty queue. *) val create : ?capacity : int (** default is [1]. *) -> unit -> _ t val singleton : 'a -> 'a t val enqueue : 'a t -> 'a -> unit val dequeue : 'a t -> 'a option val dequeue_exn : 'a t -> 'a val peek : 'a t -> 'a option val peek_exn : 'a t -> 'a val clear : _ t -> unit val copy : 'a t -> 'a t (** Transfers up to [len] elements from the front of [src] to the end of [dst], removing them from [src]. It is an error if [len < 0]. Aside from a call to [set_capacity dst] if needed, runs in O([len]) time *) val blit_transfer : src : 'a t -> dst : 'a t -> ?len : int (** default is [length src] *) -> unit -> unit (** [of_list list] returns a queue [t] with the elements of [list] in the same order as the elements of [list] (i.e. the first element of [t] is the first element of the list). *) val of_list : 'a list -> 'a t val map : 'a t -> f:('a -> 'b) -> 'b t (** creates a new queue with elements equal to [List.concat_map ~f (to_list t)]. *) val concat_map : 'a t -> f:('a -> 'b list) -> 'b t (** [filter_map] creates a new queue with elements equal to [List.filter_map ~f (to_list t)]. *) val filter_map : 'a t -> f:('a -> 'b option) -> 'b t (** [filter] is like [filter_map], except with [List.filter]. *) val filter : 'a t -> f:('a -> bool) -> 'a t (** [filter_inplace t ~f] removes all elements of [t] that don't satisfy [f]. If [f] raises, [t] is unchanged. This is inplace in that it modifies [t]; however, it uses space linear in the final length of [t]. *) val filter_inplace : 'a t -> f:('a -> bool) -> unit val of_array : 'a array -> 'a t (** [get t i] returns the [i]'th element in [t], where the 0'th element is at the front of [t] and the [length t - 1] element is at the back. *) val get : 'a t -> int -> 'a val set : 'a t -> int -> 'a -> unit (** Returns the current length of the backing array. *) val capacity : _ t -> int (** [set_capacity t capacity] sets the capacity of [t]'s backing array to at least [max capacity (length t)]. If the capacity changes, then this involves allocating a new backing array and copying the queue elements over. *) val set_capacity : _ t -> int -> unit core_kernel-113.00.00/src/core_queue_debug.ml000066400000000000000000000131551256461164500207460ustar00rootroot00000000000000open Sexplib open Sexplib.Conv module Debug (Core_queue : module type of Core_queue) = struct module Debug = Debug.Make () include Debug open Core_queue type nonrec 'a t = 'a t with bin_io, sexp let invariant = invariant let debug x = debug (invariant ignore) ~module_name:"Core_queue" x let equal equal_elt t1 t2 = debug "equal" [ t1; t2 ] (t1, t2) <:sexp_of< _ t * _ t >> <:sexp_of< bool >> (fun () -> equal equal_elt t1 t2) ;; let compare compare_elt t1 t2 = debug "compare" [ t1; t2 ] (t1, t2) <:sexp_of< _ t * _ t >> <:sexp_of< int >> (fun () -> compare compare_elt t1 t2) ;; let mem ?equal t elt = debug "mem" [ t ] t <:sexp_of< _ t >> <:sexp_of< bool >> (fun () -> mem ?equal t elt) ;; let length t = debug "length" [ t ] t <:sexp_of< _ t >> <:sexp_of< int >> (fun () -> length t) ;; let is_empty t = debug "is_empty" [ t ] t <:sexp_of< _ t >> <:sexp_of< bool >> (fun () -> is_empty t) ;; let iter t ~f = debug "iter" [ t ] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> iter t ~f) ;; let fold t ~init ~f = debug "fold" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ >> (fun () -> fold t ~init ~f) ;; let exists t ~f = debug "exists" [ t ] t <:sexp_of< _ t >> <:sexp_of< bool >> (fun () -> exists t ~f) ;; let for_all t ~f = debug "for_all" [ t ] t <:sexp_of< _ t >> <:sexp_of< bool >> (fun () -> for_all t ~f) ;; let count t ~f = debug "count" [ t ] t <:sexp_of< _ t >> <:sexp_of< int >> (fun () -> count t ~f) ;; let sum (type a) (module M : Commutative_group.S with type t = a) t ~f = debug "sum" [ t ] t <:sexp_of< _ t >> <:sexp_of< M.t >> (fun () -> sum (module M) t ~f) ;; let find t ~f = debug "find" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ option >> (fun () -> find t ~f) ;; let find_map t ~f = debug "find_map" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ option >> (fun () -> find_map t ~f) ;; let min_elt t ~cmp = debug "min_elt" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ option >> (fun () -> min_elt t ~cmp) ;; let max_elt t ~cmp = debug "max_elt" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ option >> (fun () -> max_elt t ~cmp) ;; let to_list t = debug "to_list" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ list >> (fun () -> to_list t) ;; let to_array t = debug "to_array" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ array >> (fun () -> to_array t) ;; let create ?capacity () = debug "create" [ ] capacity <:sexp_of< int option >> <:sexp_of< _ t >> (fun () -> create ?capacity ()) ;; let singleton a = debug "singleton" [ ] () <:sexp_of< unit >> <:sexp_of< _ t >> (fun () -> singleton a) ;; let enqueue t a = debug "enqueue" [ t ] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue t a) ;; let dequeue t = debug "dequeue" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ option >> (fun () -> dequeue t) ;; let dequeue_exn t = debug "dequeue_exn" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ >> (fun () -> dequeue_exn t) ;; let peek t = debug "peek" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ option >> (fun () -> peek t) ;; let peek_exn t = debug "peek_exn" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ >> (fun () -> peek_exn t) ;; let clear t = debug "clear" [ t ] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> clear t) ;; let copy t = debug "copy" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ t >> (fun () -> copy t) ;; let blit_transfer ~src ~dst ?len () = debug "blit_transfer" [ src; dst ] (src, dst, len) <:sexp_of< _ t * _ t * int option >> <:sexp_of< unit >> (fun () -> blit_transfer ~src ~dst ?len ()) ;; let of_list l = debug "of_list" [ ] l <:sexp_of< _ list >> <:sexp_of< _ t >> (fun () -> of_list l) ;; let map t ~f = debug "map" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ t >> (fun () -> map t ~f) ;; let concat_map t ~f = debug "concat_map" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ t >> (fun () -> concat_map t ~f) ;; let filter_map t ~f = debug "filter_map" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ t >> (fun () -> filter_map t ~f) ;; let filter t ~f = debug "filter" [ t ] t <:sexp_of< _ t >> <:sexp_of< _ t >> (fun () -> filter t ~f) ;; let filter_inplace t ~f = debug "filter_inplace" [ t ] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> filter_inplace t ~f) ;; let of_array a = debug "of_array" [ ] a <:sexp_of< _ array >> <:sexp_of< _ t >> (fun () -> of_array a) ;; let get t i = debug "get" [ t ] (t, i) <:sexp_of< _ t * int >> <:sexp_of< _ >> (fun () -> get t i) ;; let set t i a = debug "set" [ t ] (t, i) <:sexp_of< _ t * int >> <:sexp_of< unit >> (fun () -> set t i a) ;; let capacity t = debug "capacity" [ t ] t <:sexp_of< _ t >> <:sexp_of< int >> (fun () -> capacity t) ;; let set_capacity t capacity = debug "set_capacity" [ t ] (t, capacity) <:sexp_of< _ t * int >> <:sexp_of< unit >> (fun () -> set_capacity t capacity) ;; let binary_search ?pos ?len t ~compare which v = debug "binary_search" [ t ] (t, pos, len) <:sexp_of< _ t * int option * int option >> <:sexp_of< int option >> (fun () -> binary_search ?pos ?len t ~compare which v) ;; let binary_search_segmented ?pos ?len t ~segment_of which = debug "binary_search_segmented" [ t ] (t, pos, len) <:sexp_of< _ t * int option * int option >> <:sexp_of< int option >> (fun () -> binary_search_segmented ?pos ?len t ~segment_of which) ;; end core_kernel-113.00.00/src/core_queue_debug.mli000066400000000000000000000004261256461164500211140ustar00rootroot00000000000000module Debug (Core_queue : module type of Core_queue) : sig (** The following [include] exposes the type equivalence [Debug(Queue).t = Queue.t]. *) include module type of struct include Core_queue end val check_invariant : bool ref val show_messages : bool ref end core_kernel-113.00.00/src/core_queue_unit_tests.ml000066400000000000000000000412341256461164500220600ustar00rootroot00000000000000TEST_MODULE = (struct open Common open Sexplib.Conv module Sexp = Sexplib.Sexp module Array = Core_array module List = Core_list module Int = Core_int module Core_queue = Core_queue_debug.Debug (Core_queue) open Core_queue let does_raise = Exn.does_raise let () = show_messages := false type nonrec 'a t = 'a t with bin_io, sexp let capacity = capacity let set_capacity = set_capacity TEST_UNIT = let t = create () in assert (capacity t = 1); enqueue t 1; assert (capacity t = 1); enqueue t 2; assert (capacity t = 2); enqueue t 3; assert (capacity t = 4); set_capacity t 0; assert (capacity t = 4); set_capacity t 3; assert (capacity t = 4); set_capacity t 100; assert (capacity t = 128); enqueue t 4; enqueue t 5; set_capacity t 0; assert (capacity t = 8); ;; let round_trip_sexp t = let sexp = sexp_of_t Int.sexp_of_t t in let t' = t_of_sexp Int.t_of_sexp sexp in assert (to_list t = to_list t') ;; TEST_UNIT = round_trip_sexp (of_list [1; 2; 3; 4]) TEST_UNIT = round_trip_sexp (create ()) TEST_UNIT = round_trip_sexp (of_list []) let invariant = invariant let create = create let singleton = singleton TEST_UNIT = let t = singleton 7 in assert (length t = 1); assert (capacity t = 1); assert (dequeue t = Some 7); assert (dequeue t = None); ;; let get = get let set = set TEST_UNIT = let t = create () in let get_opt t i = try Some (get t i) with _ -> None in assert (get_opt t 0 = None); assert (get_opt t (-1) = None); assert (get_opt t 10 = None); List.iter [ -1; 0; 1 ] ~f:(fun i -> assert (does_raise (fun () -> set t i 0))); enqueue t 0; enqueue t 1; enqueue t 2; assert (get_opt t 0 = Some 0); assert (get_opt t 1 = Some 1); assert (get_opt t 2 = Some 2); assert (get_opt t 3 = None); ignore (dequeue_exn t); assert (get_opt t 0 = Some 1); assert (get_opt t 1 = Some 2); assert (get_opt t 2 = None); set t 0 3; assert (get_opt t 0 = Some 3); assert (get_opt t 1 = Some 2); List.iter [ -1; 2 ] ~f:(fun i -> assert (does_raise (fun () -> set t i 0))); ;; let map = map TEST_UNIT = for i = 0 to 5 do let l = List.init i ~f:Fn.id in let t = of_list l in let f x = x * 2 in let t' = map t ~f in assert (to_list t' = List.map l ~f); done ;; TEST_UNIT = let t = create () in let t' = map t ~f:(fun x -> x * 2) in assert (length t' = length t); assert (length t' = 0); assert (to_list t' = []); ;; include Container_unit_tests.Test_S1 (Core_queue) let dequeue_exn = dequeue_exn let enqueue = enqueue let peek = peek let peek_exn = peek_exn TEST_UNIT = let t = create () in assert (is_none (peek t)); enqueue t 1; enqueue t 2; assert (peek t = Some 1); assert (peek_exn t = 1); assert (dequeue_exn t = 1); assert (dequeue_exn t = 2); assert (does_raise (fun () -> dequeue_exn t)); assert (does_raise (fun () -> peek_exn t)); ;; let of_list = of_list let to_list = to_list TEST_UNIT = for i = 0 to 4 do let list = List.init i ~f:Fn.id in assert (Poly.equal (to_list (of_list list)) list); done; ;; TEST = let t = create () in begin for i = 1 to 5 do enqueue t i done; to_list t = [1;2;3;4;5] end ;; let of_array = of_array let to_array = to_array TEST_UNIT = for len = 0 to 4 do let array = Array.init len ~f:Fn.id in assert (Poly.equal (to_array (of_array array)) array); done; ;; let compare = compare let equal = equal TEST_MODULE "comparisons" = struct let sign x = if x < 0 then ~-1 else if x > 0 then 1 else 0 let test t1 t2 = <:test_result< bool >> (equal Int.equal t1 t2) ~expect:(List.equal ~equal:Int.equal (to_list t1) (to_list t2)); <:test_result< int >> (sign (compare Int.compare t1 t2)) ~expect:(sign (List.compare Int.compare (to_list t1) (to_list t2))) ;; let lists = [ [] ; [ 1 ] ; [ 2 ] ; [ 1; 1 ] ; [ 1; 2 ] ; [ 2; 1 ] ; [ 1; 1; 1 ] ; [ 1; 2; 3 ] ; [ 1; 2; 4 ] ; [ 1; 2; 4; 8 ] ; [ 1; 2; 3; 4; 5 ] ] ;; TEST_UNIT = (* [phys_equal] inputs *) List.iter lists ~f:(fun list -> let t = of_list list in test t t) ;; TEST_UNIT = List.iter lists ~f:(fun list1 -> List.iter lists ~f:(fun list2 -> test (of_list list1) (of_list list2))) ;; end let clear = clear let concat_map = concat_map let blit_transfer = blit_transfer TEST_UNIT = let q_list = [1; 2; 3; 4] in let q = of_list q_list in let q' = create () in blit_transfer ~src:q ~dst:q' (); assert (to_list q' = q_list); assert (to_list q = []); ;; TEST_UNIT = let q = of_list [1; 2; 3; 4] in let q' = create () in blit_transfer ~src:q ~dst:q' ~len:2 (); assert (to_list q' = [1; 2]); assert (to_list q = [3; 4]); ;; TEST_UNIT "blit_transfer on wrapped queues" = let list = [1; 2; 3; 4] in let q = of_list list in let q' = copy q in ignore (dequeue_exn q); ignore (dequeue_exn q); ignore (dequeue_exn q'); ignore (dequeue_exn q'); ignore (dequeue_exn q'); enqueue q 5; enqueue q 6; blit_transfer ~src:q ~dst:q' ~len:3 (); assert (to_list q' = [4; 3; 4; 5]); assert (to_list q = [6]); ;; let copy = copy let dequeue = dequeue let filter = filter let filter_inplace = filter_inplace let filter_map = filter_map let iter = iter TEST_MODULE "Linked_queue bisimulation" = struct module type Queue_intf = sig type 'a t with sexp_of val create : unit -> 'a t val enqueue : 'a t -> 'a -> unit val dequeue : 'a t -> 'a option val to_array : 'a t -> 'a array val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b val iter : 'a t -> f:('a -> unit) -> unit val length : 'a t -> int val clear : 'a t -> unit val concat_map : 'a t -> f:('a -> 'b list) -> 'b t val filter_map : 'a t -> f:('a -> 'b option) -> 'b t val filter : 'a t -> f:('a -> bool) -> 'a t val filter_inplace : 'a t -> f:('a -> bool) -> unit val transfer : src:'a t -> dst:'a t -> unit val copy : 'a t -> 'a t end module That_queue : Queue_intf = Linked_queue module This_queue : Queue_intf = struct include Core_queue let create () = create () let transfer ~src ~dst = blit_transfer ~src ~dst () end let this_to_string this_t = Sexp.to_string (this_t |> <:sexp_of< int This_queue.t >>) ;; let that_to_string that_t = Sexp.to_string (that_t |> <:sexp_of< int That_queue.t >>) ;; let array_string arr = Sexp.to_string (arr |> <:sexp_of< int array >>) ;; let create () = (This_queue.create (), That_queue.create ()) let enqueue (t_a, t_b) v = let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in This_queue.enqueue t_a v; That_queue.enqueue t_b v; let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in if end_a <> end_b then failwithf "enqueue transition failure of: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) (array_string start_b) (array_string end_b) () ;; let iter (t_a, t_b) = let r_a, r_b = ref 0, ref 0 in This_queue.iter t_a ~f:(fun x -> r_a := !r_a + x); That_queue.iter t_b ~f:(fun x -> r_b := !r_b + x); if !r_a <> !r_b then failwithf "error in iter: %s (from %s) <> %s (from %s)" (Int.to_string !r_a) (this_to_string t_a) (Int.to_string !r_b) (that_to_string t_b) () ;; let dequeue (t_a, t_b) = let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in let a, b = This_queue.dequeue t_a, That_queue.dequeue t_b in let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in if a <> b || end_a <> end_b then failwithf "error in dequeue: %s (%s -> %s) <> %s (%s -> %s)" (Option.value ~default:"None" (Option.map a ~f:Int.to_string)) (array_string start_a) (array_string end_a) (Option.value ~default:"None" (Option.map b ~f:Int.to_string)) (array_string start_b) (array_string end_b) () ;; let clear (t_a, t_b) = This_queue.clear t_a; That_queue.clear t_b; ;; let is_even x = (x land 1) = 0 let filter (t_a, t_b) = let t_a' = This_queue.filter t_a ~f:is_even in let t_b' = That_queue.filter t_b ~f:is_even in if This_queue.to_array t_a' <> That_queue.to_array t_b' then failwithf "error in filter: %s -> %s vs. %s -> %s" (this_to_string t_a) (this_to_string t_a') (that_to_string t_b) (that_to_string t_b') () ;; let filter_inplace (t_a, t_b) = let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in This_queue.filter_inplace t_a ~f:is_even; That_queue.filter_inplace t_b ~f:is_even; let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in if end_a <> end_b then failwithf "error in filter_inplace: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) (array_string start_b) (array_string end_b) () ;; let concat_map (t_a, t_b) = let f x = [x; x + 1; x + 2] in let t_a' = This_queue.concat_map t_a ~f in let t_b' = That_queue.concat_map t_b ~f in if (This_queue.to_array t_a') <> (That_queue.to_array t_b') then failwithf "error in concat_map: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) (that_to_string t_b') (that_to_string t_b) () ;; let filter_map (t_a, t_b) = let f x = if is_even x then None else Some (x + 1) in let t_a' = This_queue.filter_map t_a ~f in let t_b' = That_queue.filter_map t_b ~f in if (This_queue.to_array t_a') <> (That_queue.to_array t_b') then failwithf "error in filter_map: %s (for %s) <> %s (for %s)" (this_to_string t_a') (this_to_string t_a) (that_to_string t_b') (that_to_string t_b) () ;; let copy (t_a, t_b) = let copy_a = This_queue.copy t_a in let copy_b = That_queue.copy t_b in let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in let end_a = This_queue.to_array copy_a in let end_b = That_queue.to_array copy_b in if end_a <> end_b then failwithf "error in copy: %s -> %s vs. %s -> %s" (array_string start_a) (array_string end_a) (array_string start_b) (array_string end_b) () ;; let transfer (t_a, t_b) = let dst_a = This_queue.create () in let dst_b = That_queue.create () in (* sometimes puts some elements in the destination queues *) if Random.bool () then begin List.iter [ 1; 2; 3; 4; 5 ] ~f:(fun elem -> This_queue.enqueue dst_a elem; That_queue.enqueue dst_b elem); end; let start_a = This_queue.to_array t_a in let start_b = That_queue.to_array t_b in This_queue.transfer ~src:t_a ~dst:dst_a; That_queue.transfer ~src:t_b ~dst:dst_b; let end_a = This_queue.to_array t_a in let end_b = That_queue.to_array t_b in let end_a' = This_queue.to_array dst_a in let end_b' = That_queue.to_array dst_b in if end_a' <> end_b' || end_a <> end_b then failwithf "error in transfer: %s -> (%s, %s) vs. %s -> (%s, %s)" (array_string start_a) (array_string end_a) (array_string end_a') (array_string start_b) (array_string end_b) (array_string end_b) () ;; let fold_check (t_a, t_b) = let make_list fold t = fold t ~init:[] ~f:(fun acc x -> x :: acc) in let this_l = make_list This_queue.fold t_a in let that_l = make_list That_queue.fold t_b in if this_l <> that_l then failwithf "error in fold: %s (from %s) <> %s (from %s)" (Sexp.to_string (this_l |> <:sexp_of< int list >>)) (this_to_string t_a) (Sexp.to_string (that_l |> <:sexp_of< int list >>)) (that_to_string t_b) () ;; let length_check (t_a, t_b) = let this_len = This_queue.length t_a in let that_len = That_queue.length t_b in if this_len <> that_len then failwithf "error in length: %i (for %s) <> %i (for %s)" this_len (this_to_string t_a) that_len (that_to_string t_b) () ;; TEST_UNIT = let t = create () in let rec loop ~all_ops ~non_empty_ops = if all_ops <= 0 && non_empty_ops <= 0 then begin let (t_a, t_b) = t in let arr_a = This_queue.to_array t_a in let arr_b = That_queue.to_array t_b in if arr_a <> arr_b then failwithf "queue final states not equal: %s vs. %s" (array_string arr_a) (array_string arr_b) () end else begin let queue_was_empty = This_queue.length (fst t) = 0 in let r = Random.int 160 in begin if r < 60 then enqueue t (Random.int 10_000) else if r < 65 then dequeue t else if r < 70 then clear t else if r < 80 then iter t else if r < 90 then fold_check t else if r < 100 then filter t else if r < 110 then concat_map t else if r < 120 then transfer t else if r < 130 then filter_map t else if r < 140 then copy t else if r < 150 then filter_inplace t else length_check t end; loop ~all_ops:(all_ops - 1) ~non_empty_ops:(if queue_was_empty then non_empty_ops else non_empty_ops - 1) end in loop ~all_ops:7_500 ~non_empty_ops:5_000 ;; end let binary_search = binary_search let binary_search_segmented = binary_search_segmented TEST_UNIT "modification-during-iteration" = let x = `A 0 in let t = of_list [x; x] in let f (`A n) = ignore n; clear t in assert (does_raise (fun () -> iter t ~f)); ;; TEST_UNIT "more-modification-during-iteration" = let nested_iter_okay = ref false in let t = of_list [ `iter; `clear ] in assert (does_raise (fun () -> iter t ~f:(function | `iter -> iter t ~f:ignore; nested_iter_okay := true | `clear -> clear t))); assert !nested_iter_okay; ;; TEST_UNIT "modification-during-filter" = let reached_unreachable = ref false in let t = of_list [`clear; `unreachable] in let f x = match x with | `clear -> clear t; false | `unreachable -> reached_unreachable := true; false in assert (does_raise (fun () -> filter t ~f)); assert (not !reached_unreachable); ;; TEST_UNIT "modification-during-filter-inplace" = let reached_unreachable = ref false in let t = of_list [`drop_this; `enqueue_new_element; `unreachable] in let f x = begin match x with | `drop_this | `new_element -> () | `enqueue_new_element -> enqueue t `new_element | `unreachable -> reached_unreachable := true end; false in assert (does_raise (fun () -> filter_inplace t ~f)); (* even though we said to drop the first element, the aborted call to [filter_inplace] shouldn't have made that change *) assert (peek_exn t = `drop_this); assert (not !reached_unreachable); ;; TEST_UNIT "filter-inplace-during-iteration" = let reached_unreachable = ref false in let t = of_list [`filter_inplace; `unreachable] in let f x = match x with | `filter_inplace -> filter_inplace t ~f:(fun _ -> false) | `unreachable -> reached_unreachable := true in assert (does_raise (fun () -> iter t ~f)); assert (not !reached_unreachable); ;; end (** This signature is here to remind us to update the unit tests whenever we change [Core_queue]. *) : module type of Core_queue) core_kernel-113.00.00/src/core_queue_unit_tests.mli000066400000000000000000000000551256461164500222250ustar00rootroot00000000000000(** This signature is deliberately empty. *) core_kernel-113.00.00/src/core_random.ml000066400000000000000000000046671256461164500177440ustar00rootroot00000000000000(* Unfortunately, because the standard library does not expose [Random.State.default], we have to construct our own. We then build the [Random.int], [Random.bool] functions and friends using that default state in exactly the same way as the standard library. One other trickiness is that we need access to the unexposed [Random.State.assign] function, which accesses the unexposed state representation. So, we copy the [State.repr] type definition and [assign] function to here from the standard library, and use [Obj.magic] to get access to the underlying implementation. *) open Random external random_seed: unit -> int array = "caml_sys_random_seed";; TEST_UNIT = (* test that the return type of "caml_sys_random_seed" is what we expect *) let obj = Obj.repr (random_seed ()) in assert (Obj.is_block obj); assert (Obj.tag obj = Obj.tag (Obj.repr [| 13 |])); for i = 0 to Obj.size obj - 1 do assert (Obj.is_int (Obj.field obj i)); done; ;; module State = struct include State type repr = { st : int array; mutable idx : int } let assign t1 t2 = let t1 = (Obj.magic t1 : repr) in let t2 = (Obj.magic t2 : repr) in Array.blit t2.st 0 t1.st 0 (Array.length t1.st); t1.idx <- t2.idx; ;; let full_init t seed = assign t (make seed) let default = (* We define Core's default random state as a copy of OCaml's default random state. This means that programs that use Core.Random will see the same sequence of random bits as if they had used OCaml.Random. However, because [get_state] returns a copy, Core.Random and OCaml.Random are not using the same state. If a program used both, each of them would go through the same sequence of random bits. To avoid that, we reset OCaml's random state to a different seed, giving it a different sequence. *) let t = Random.get_state () in Random.init 137; t ;; end let default = State.default let bits () = State.bits default let int bound = State.int default bound let int32 bound = State.int32 default bound let nativeint bound = State.nativeint default bound let int64 bound = State.int64 default bound let float scale = State.float default scale let bool () = State.bool default let full_init seed = State.full_init default seed let init seed = full_init [| seed |] let self_init () = full_init (random_seed ()) let get_state () = `Consider_using_Random_State_default let set_state s = State.assign default s core_kernel-113.00.00/src/core_random.mli000066400000000000000000000111421256461164500200770ustar00rootroot00000000000000(** This is a slightly modified version of the OCaml standard library's random.mli. We want Core's [Random] module to be different from OCaml's standard one: - We expose [Random.State.default], so that user code can easily share the default random state if it wants. - We disallow [Random.get_state], because it misleadingly makes a copy of random state. And it is what people naturally, albeit incorrectly, grab for when they want to use shared random state. The fact that we construct our own default random state means that code using Core.Std.Random and code using OCaml's Random will not share the default state. *) (***********************************************************************) (* *) (* Objective Caml *) (* *) (* Damien Doligez, projet Para, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id: random.mli 10457 2010-05-21 18:30:12Z doligez $ *) (** Pseudo-random number generators (PRNG). *) (** {6 Basic functions} *) (** Note that all of these "basic" functions mutate a global random state. *) (** Initialize the generator, using the argument as a seed. The same seed will always yield the same sequence of numbers. *) val init : int -> unit (** Same as {!Random.init} but takes more data as seed. *) val full_init : int array -> unit (** Initialize the generator with a more-or-less random seed chosen in a system-dependent way. *) val self_init : unit -> unit (** Return 30 random bits in a nonnegative integer. @before 3.12.0 used a different algorithm (affects all the following functions) *) val bits : unit -> int (** [Random.int bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0 and less than 2{^30}. *) val int : int -> int (** [Random.int32 bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val int32 : Int32.t -> Int32.t;; (** [Random.nativeint bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val nativeint : Nativeint.t -> Nativeint.t;; (** [Random.int64 bound] returns a random integer between 0 (inclusive) and [bound] (exclusive). [bound] must be greater than 0. *) val int64 : Int64.t -> Int64.t;; (** [Random.float bound] returns a random floating-point number between 0 (inclusive) and [bound] (exclusive). If [bound] is negative, the result is negative or zero. If [bound] is 0, the result is 0. *) val float : float -> float (** [Random.bool ()] returns [true] or [false] with probability 0.5 each. *) val bool : unit -> bool (** {6 Advanced functions} *) (** The functions from module [State] manipulate the current state of the random generator explicitely. This allows using one or several deterministic PRNGs, even in a multi-threaded program, without interference from other parts of the program. *) module State : sig type t val default : t (** Create a new state and initialize it with the given seed. *) val make : int array -> t (** Create a new state and initialize it with a system-dependent low-entropy seed. *) val make_self_init : unit -> t val copy : t -> t (** These functions are the same as the basic functions, except that they use (and update) the given PRNG state instead of the default one. *) val bits : t -> int val int : t -> int -> int val int32 : t -> Int32.t -> Int32.t val nativeint : t -> Nativeint.t -> Nativeint.t val int64 : t -> Int64.t -> Int64.t val float : t -> float -> float val bool : t -> bool end;; (** OCaml's [Random.get_state] makes a copy of the default state, which is almost certainly not what you want. [State.default], which is the actual default state, is probably what you want. *) val get_state : unit -> [ `Consider_using_Random_State_default ] (** Set the state of the generator used by the basic functions. *) val set_state : State.t -> unit core_kernel-113.00.00/src/core_set.ml000066400000000000000000001251231256461164500172460ustar00rootroot00000000000000(***********************************************************************) (* *) (* Objective Caml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. All rights reserved. This file is distributed *) (* under the terms of the GNU Library General Public License, with *) (* the special exception on linking described in file ../LICENSE. *) (* *) (***********************************************************************) (* $Id: pSet.ml,v 1.2 2003/09/10 15:40:01 sandor Exp $ *) (* Sets over ordered types *) open Sexplib open Core_set_intf open With_return module Array = Core_array module List = Core_list module Map = Core_map open Int_replace_polymorphic_compare module type Elt = Elt module type Elt_binable = Elt_binable module Tree0 = struct type 'a t = | Empty (* (Leaf x) is the same as (Node (Empty, x, Empty, 1, 1)) but uses less space. *) | Leaf of 'a (* first int is height, second is sub-tree size *) | Node of 'a t * 'a * 'a t * int * int type 'a tree = 'a t (* Sets are represented by balanced binary trees (the heights of the children differ by at most 2. *) let height = function | Empty -> 0 | Leaf _ -> 1 | Node(_, _, _, h, _) -> h ;; let length = function | Empty -> 0 | Leaf _ -> 1 | Node(_, _, _, _, s) -> s ;; let invariants t ~compare_elt = let rec loop lower upper t = let in_range v = (match lower with | None -> true | Some lower -> compare_elt lower v < 0 ) && (match upper with | None -> true | Some upper -> compare_elt v upper < 0 ) in match t with | Empty -> true | Leaf v -> in_range v | Node (l, v, r, h, n) -> let hl = height l and hr = height r in abs (hl - hr) <= 2 && h = (max hl hr) + 1 && n = length l + length r + 1 && in_range v && loop lower (Some v) l && loop (Some v) upper r in loop None None t ;; let is_empty = function Empty -> true | Leaf _ | Node _ -> false (* Creates a new node with left son l, value v and right son r. We must have all elements of l < v < all elements of r. l and r must be balanced and | height l - height r | <= 2. Inline expansion of height for better speed. *) let create l v r = let hl = match l with Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,h,_) -> h in let hr = match r with Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,h,_) -> h in let h = if hl >= hr then hl + 1 else hr + 1 in if h = 1 then Leaf v else begin let sl = match l with Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,_,s) -> s in let sr = match r with Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,_,s) -> s in Node (l, v, r, h, sl + sr + 1) end let of_sorted_array_unchecked array ~compare_elt = let array_length = Array.length array in let arr = (* We don't check if the array is sorted or keys are duplicated, because that checking is slower than the whole [of_sorted_array] function *) if array_length < 2 || compare_elt array.(0) array.(1) < 0 then (fun i -> array.(i)) else (fun i -> array.(array_length - 1 - i)) in let rec loop i j = match j - i with | x when x < 0 -> assert false | 0 -> Empty | 1 -> Leaf (arr i) | 2 -> Node (Leaf (arr i), arr (i + 1), Empty, 2, 2) | 3 -> Node (Leaf (arr i), arr (i + 1), Leaf (arr (i + 2)), 2, 3) | n -> let left_length = n / 2 in let left_i, left_j = i, i + left_length in let right_i, right_j = i + left_length + 1, j in create (loop left_i left_j) (arr (i + left_length)) (loop right_i right_j) in loop 0 (Array.length array) ;; let of_sorted_array array ~compare_elt = match array with | [||] | [|_|] -> Result.Ok (of_sorted_array_unchecked array ~compare_elt) | _ -> with_return (fun r -> let increasing = match compare_elt array.(0) array.(1) with | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> i < 0 in for i = 1 to Array.length array - 2 do match compare_elt array.(i) array.(i+1) with | 0 -> r.return (Or_error.error_string "of_sorted_array: duplicated elements") | i -> if Pervasives.(<>) (i < 0) increasing then r.return (Or_error.error_string "of_sorted_array: elements are not ordered") done; Result.Ok (of_sorted_array_unchecked array ~compare_elt) ) (* Same as create, but performs one step of rebalancing if necessary. Assumes l and r balanced and | height l - height r | <= 3. Inline expansion of create for better speed in the most frequent case where no rebalancing is required. *) let bal l v r = let hl = match l with Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,h,_) -> h in let hr = match r with Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,h,_) -> h in if hl > hr + 2 then begin match l with | Empty -> assert false | Leaf _ -> assert false (* because h(l)>h(r)+2 and h(leaf)=1 *) | Node (ll, lv, lr, _, _) -> if height ll >= height lr then create ll lv (create lr v r) else begin match lr with | Empty -> assert false | Leaf lrv -> assert (is_empty ll); create (create ll lv Empty) lrv (create Empty v r) | Node(lrl, lrv, lrr, _, _)-> create (create ll lv lrl) lrv (create lrr v r) end end else if hr > hl + 2 then begin match r with Empty -> assert false | Leaf rv -> create (create l v Empty) rv Empty | Node(rl, rv, rr, _, _) -> if height rr >= height rl then create (create l v rl) rv rr else begin match rl with Empty -> assert false | Leaf rlv -> assert (is_empty rr); create (create l v Empty) rlv (create Empty rv rr) | Node(rll, rlv, rlr, _, _) -> create (create l v rll) rlv (create rlr rv rr) end end else begin let h = if hl >= hr then hl + 1 else hr + 1 in let sl = match l with Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,_,s) -> s in let sr = match r with Empty -> 0 | Leaf _ -> 1 | Node(_,_,_,_,s) -> s in if h = 1 then Leaf v else Node (l, v, r, h, sl + sr + 1) end (* Insertion of one element *) exception Same let add t x ~compare_elt = let rec aux = function | Empty -> Leaf x | Leaf v -> let c = compare_elt x v in if c = 0 then raise Same else if c < 0 then bal (Leaf x) v Empty else bal Empty v (Leaf x) | Node(l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then raise Same else if c < 0 then bal (aux l) v r else bal l v (aux r) in try aux t with Same -> t ;; (* Same as create and bal, but no assumptions are made on the relative heights of l and r. *) let rec join l v r ~compare_elt = match (l, r) with | (Empty, _) -> add r v ~compare_elt | (_, Empty) -> add l v ~compare_elt | (Leaf lv, _) -> add (add r v ~compare_elt) lv ~compare_elt | (_, Leaf rv) -> add (add l v ~compare_elt) rv ~compare_elt | (Node (ll, lv, lr, lh, _), Node (rl, rv, rr, rh, _)) -> if lh > rh + 2 then bal ll lv (join lr v r ~compare_elt) else if rh > lh + 2 then bal (join l v rl ~compare_elt) rv rr else create l v r ;; (* Smallest and greatest element of a set *) let rec min_elt = function | Empty -> None | Leaf v | Node(Empty, v, _, _, _) -> Some v | Node(l, _, _, _, _) -> min_elt l ;; exception Set_min_elt_exn_of_empty_set with sexp exception Set_max_elt_exn_of_empty_set with sexp let min_elt_exn t = match min_elt t with | None -> raise Set_min_elt_exn_of_empty_set | Some v -> v ;; let fold_until t ~init ~f = let rec fold_until_helper ~f t acc = match t with | Empty -> `Continue acc | Leaf value -> f acc value | Node(left, value, right, _, _) -> match fold_until_helper ~f left acc with | `Stop _a as x -> x | `Continue acc -> match f acc value with | `Stop _a as x -> x | `Continue a -> fold_until_helper ~f right a in match fold_until_helper ~f t init with | `Stop a -> a (* `Continue case is reached if Set is exhausted without `Stop being returned. This will happen if t is empty, for example. *) | `Continue a -> a ;; let rec max_elt = function | Empty -> None | Leaf v | Node(_, v, Empty, _, _) -> Some v | Node(_, _, r, _, _) -> max_elt r ;; let max_elt_exn t = match max_elt t with | None -> raise Set_max_elt_exn_of_empty_set | Some v -> v ;; (* Remove the smallest element of the given set *) let rec remove_min_elt = function | Empty -> invalid_arg "Set.remove_min_elt" | Leaf _ -> Empty | Node(Empty, _, r, _, _) -> r | Node(l, v, r, _, _) -> bal (remove_min_elt l) v r ;; (* Merge two trees l and r into one. All elements of l must precede the elements of r. Assume | height l - height r | <= 2. *) let merge t1 t2 = match (t1, t2) with | (Empty, t) -> t | (t, Empty) -> t | (_, _) -> bal t1 (min_elt_exn t2) (remove_min_elt t2) ;; (* Merge two trees l and r into one. All elements of l must precede the elements of r. No assumption on the heights of l and r. *) let concat t1 t2 ~compare_elt = match (t1, t2) with | Empty, t | t, Empty -> t | (_, _) -> join t1 (min_elt_exn t2) (remove_min_elt t2) ~compare_elt ;; let split t x ~compare_elt = let rec split t = match t with | Empty -> (Empty, None, Empty) | Leaf v -> let c = compare_elt x v in if c = 0 then (Empty, Some v, Empty) else if c < 0 then (Empty, None, Leaf v) else (Leaf v, None, Empty) | Node (l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then (l, Some v, r) else if c < 0 then let (ll, maybe_elt, rl) = split l in (ll, maybe_elt, join rl v r ~compare_elt) else let (lr, maybe_elt, rr) = split r in (join l v lr ~compare_elt, maybe_elt, rr) in split t ;; (* Implementation of the set operations *) let empty = Empty let rec mem t x ~compare_elt = match t with | Empty -> false | Leaf v -> let c = compare_elt x v in c = 0 | Node(l, v, r, _, _) -> let c = compare_elt x v in c = 0 || mem (if c < 0 then l else r) x ~compare_elt ;; let singleton x = Leaf x let remove t x ~compare_elt = let rec aux t = match t with | Empty -> raise Same | Leaf v -> if compare_elt x v = 0 then Empty else raise Same | Node(l, v, r, _, _) -> let c = compare_elt x v in if c = 0 then merge l r else if c < 0 then bal (aux l) v r else bal l v (aux r) in try aux t with Same -> t ;; let remove_index t i ~compare_elt:_ = let rec aux t i = match t with | Empty -> raise Same | Leaf _ -> if i = 0 then Empty else raise Same | Node (l, v, r, _, _) -> let l_size = length l in let c = Pervasives.compare i l_size in if c = 0 then merge l r else if c < 0 then bal (aux l i) v r else bal l v (aux r (i - l_size - 1)) in try aux t i with Same -> t ;; let union s1 s2 ~compare_elt = let rec union s1 s2 = match s1, s2 with | Empty, t | t, Empty -> t | Leaf v1, _ -> union (Node(Empty, v1, Empty, 1, 1)) s2 | _, Leaf v2 -> union s1 (Node(Empty, v2, Empty, 1, 1)) | (Node(l1, v1, r1, h1, _), Node(l2, v2, r2, h2, _)) -> if h1 >= h2 then if h2 = 1 then add s1 v2 ~compare_elt else begin let (l2, _, r2) = split s2 v1 ~compare_elt in join (union l1 l2) v1 (union r1 r2) ~compare_elt end else if h1 = 1 then add s2 v1 ~compare_elt else begin let (l1, _, r1) = split s1 v2 ~compare_elt in join (union l1 l2) v2 (union r1 r2) ~compare_elt end in union s1 s2 ;; let union_list ~comparator ~to_tree xs = let compare_elt = comparator.Comparator.compare in List.fold xs ~init:empty ~f:(fun ac x -> union ac (to_tree x) ~compare_elt) ;; let inter s1 s2 ~compare_elt = let rec inter s1 s2 = match s1, s2 with | Empty, _ | _, Empty -> Empty | ((Leaf elt as singleton), other_set) | (other_set, (Leaf elt as singleton)) -> if mem other_set elt ~compare_elt then singleton else Empty | (Node (l1, v1, r1, _, _), t2) -> match split t2 v1 ~compare_elt with | (l2, None, r2) -> concat (inter l1 l2) (inter r1 r2) ~compare_elt | (l2, Some v1, r2) -> join (inter l1 l2) v1 (inter r1 r2) ~compare_elt in inter s1 s2 ;; let diff s1 s2 ~compare_elt = let rec diff s1 s2 = match s1, s2 with | (Empty, _) -> Empty | (t1, Empty) -> t1 | (Leaf v1, t2) -> diff (Node(Empty, v1, Empty, 1, 1)) t2 | (Node(l1, v1, r1, _, _), t2) -> match split t2 v1 ~compare_elt with | (l2, None, r2) -> join (diff l1 l2) v1 (diff r1 r2) ~compare_elt | (l2, Some _, r2) -> concat (diff l1 l2) (diff r1 r2) ~compare_elt in diff s1 s2 ;; module Enum = struct type increasing type decreasing type ('a, 'direction) t = End | More of 'a * 'a tree * ('a, 'direction) t let rec cons s (e : (_, increasing) t) : (_, increasing) t = match s with | Empty -> e | Leaf v -> (More (v, Empty, e)) | Node (l, v, r, _, _) -> cons l (More (v, r, e)) ;; let rec cons_right s (e : (_, decreasing) t) : (_, decreasing) t = match s with | Empty -> e | Leaf v -> More (v, Empty, e) | Node (l, v, r, _, _) -> cons_right r (More (v, l, e)) ;; let of_set s : (_, increasing) t = cons s End let of_set_right s : (_, decreasing) t = cons_right s End let starting_at_increasing t key compare : (_, increasing) t = let rec loop t e = match t with | Empty -> e | Leaf v -> loop (Node (Empty, v, Empty, 1, 1)) e | Node(_, v, r, _, _) when compare v key < 0 -> loop r e | Node(l, v, r, _, _) -> loop l (More(v, r, e)) in loop t End ;; let starting_at_decreasing t key compare : (_, decreasing) t = let rec loop t e = match t with | Empty -> e | Leaf v -> loop (Node (Empty, v, Empty, 1, 1)) e | Node(l, v, _, _, _) when compare v key > 0 -> loop l e | Node(l, v, r, _, _) -> loop r (More(v, l, e)) in loop t End ;; let compare compare_elt e1 e2 = let rec loop e1 e2 = match e1, e2 with | End, End -> 0 | End, _ -> -1 | _, End -> 1 | More (v1, r1, e1), More (v2, r2, e2) -> let c = compare_elt v1 v2 in if c <> 0 then c else loop (cons r1 e1) (cons r2 e2) in loop e1 e2 ;; let rec iter ~f = function | End -> () | More (a, tree, enum) -> f a; iter (cons tree enum) ~f ;; let iter2 compare_elt t1 t2 ~f = let rec loop t1 t2 = match t1, t2 with | End, End -> () | End, _ -> iter t2 ~f:(fun a -> f (`Right a)) | _, End -> iter t1 ~f:(fun a -> f (`Left a)) | More (a1, tree1, enum1), More (a2, tree2, enum2) -> let compare_result = compare_elt a1 a2 in if compare_result = 0 then begin f (`Both (a1, a2)); loop (cons tree1 enum1) (cons tree2 enum2) end else if compare_result < 0 then begin f (`Left a1); loop (cons tree1 enum1) t2 end else begin f (`Right a2); loop t1 (cons tree2 enum2) end in loop t1 t2 let symmetric_diff t1 t2 ~compare_elt = let step state : ((_,_) Either.t, _) Sequence.Step.t = match state with | End, End -> Done | End, More (elt, tree, enum) -> Yield (Second elt, (End, cons tree enum)) | More (elt, tree, enum), End -> Yield (First elt, (cons tree enum, End)) | (More (a1, tree1, enum1) as left), (More (a2, tree2, enum2) as right) -> let compare_result = compare_elt a1 a2 in if compare_result = 0 then begin let next_state = if Pervasives.(==) tree1 tree2 then (enum1, enum2) else (cons tree1 enum1, cons tree2 enum2) in Skip next_state end else if compare_result < 0 then begin Yield (First a1, (cons tree1 enum1, right)) end else begin Yield (Second a2, (left, cons tree2 enum2)) end in Sequence.unfold_step ~init:(of_set t1, of_set t2) ~f:step ;; end let to_sequence_increasing comparator ~from_elt t = let next enum = match enum with | Enum.End -> Sequence.Step.Done | Enum.More (k, t, e) -> Sequence.Step.Yield (k, Enum.cons t e) in let init = match from_elt with | None -> Enum.of_set t | Some key -> Enum.starting_at_increasing t key comparator.Comparator.compare in Sequence.unfold_step ~init ~f:next ;; let to_sequence_decreasing comparator ~from_elt t = let next enum = match enum with | Enum.End -> Sequence.Step.Done | Enum.More (k, t, e) -> Sequence.Step.Yield (k, Enum.cons_right t e) in let init = match from_elt with | None -> Enum.of_set_right t | Some key -> Enum.starting_at_decreasing t key comparator.Comparator.compare in Sequence.unfold_step ~init ~f:next ;; let to_sequence comparator ?(order = `Increasing) ?greater_or_equal_to ?less_or_equal_to t = let inclusive_bound side t bound = let compare_elt = comparator.Comparator.compare in let l, maybe, r = split t bound ~compare_elt in let t = side (l, r) in match maybe with | None -> t | Some elt -> add t elt ~compare_elt in match order with | `Increasing -> let t = Option.fold less_or_equal_to ~init:t ~f:(inclusive_bound fst) in to_sequence_increasing comparator ~from_elt:greater_or_equal_to t | `Decreasing -> let t = Option.fold greater_or_equal_to ~init:t ~f:(inclusive_bound snd) in to_sequence_decreasing comparator ~from_elt:less_or_equal_to t ;; let compare compare_elt s1 s2 = Enum.compare compare_elt (Enum.of_set s1) (Enum.of_set s2) ;; let iter2 s1 s2 ~compare_elt = Enum.iter2 compare_elt (Enum.of_set s1) (Enum.of_set s2) let equal s1 s2 ~compare_elt = compare compare_elt s1 s2 = 0 let subset s1 s2 ~compare_elt = let rec subset s1 s2 = match s1, s2 with | Empty, _ -> true | _, Empty -> false | Leaf v1, t2 -> mem t2 v1 ~compare_elt | Node (l1, v1, r1, _, _), Leaf v2 -> begin match l1, r1 with | Empty, Empty -> (* This case shouldn't occur in practice because we should have constructed a Leaf rather than a Node with two Empty subtrees *) compare_elt v1 v2 = 0 | _, _ -> false end | Node (l1, v1, r1, _, _), (Node (l2, v2, r2, _, _) as t2) -> let c = compare_elt v1 v2 in if c = 0 then subset l1 l2 && subset r1 r2 (* Note that height and size don't matter here. *) else if c < 0 then subset (Node (l1, v1, Empty, 0, 0)) l2 && subset r1 t2 else subset (Node (Empty, v1, r1, 0, 0)) r2 && subset l1 t2 in subset s1 s2 ;; let iter t ~f = let rec iter = function | Empty -> () | Leaf v -> f v | Node(l, v, r, _, _) -> iter l; f v; iter r in iter t ;; let symmetric_diff = Enum.symmetric_diff let rec fold s ~init:accu ~f = match s with | Empty -> accu | Leaf v -> f accu v | Node(l, v, r, _, _) -> fold ~f r ~init:(f (fold ~f l ~init:accu) v) ;; let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let rec fold_right s ~init:accu ~f = match s with | Empty -> accu | Leaf v -> f v accu | Node(l, v, r, _, _) -> fold_right ~f l ~init:(f v (fold_right ~f r ~init:accu)) ;; let rec for_all t ~f:p = match t with | Empty -> true | Leaf v -> p v | Node(l, v, r, _, _) -> p v && for_all ~f:p l && for_all ~f:p r ;; let rec exists t ~f:p = match t with | Empty -> false | Leaf v -> p v | Node(l, v, r, _, _) -> p v || exists ~f:p l || exists ~f:p r ;; let filter s ~f:p ~compare_elt = let rec filt accu = function | Empty -> accu | Leaf v -> if p v then add accu v ~compare_elt else accu | Node(l, v, r, _, _) -> filt (filt (if p v then add accu v ~compare_elt else accu) l) r in filt Empty s ;; let filter_map s ~f:p ~compare_elt = let rec filt accu = function | Empty -> accu | Leaf v -> (match p v with | None -> accu | Some v -> add accu v ~compare_elt) | Node(l, v, r, _, _) -> filt (filt (match p v with | None -> accu | Some v -> add accu v ~compare_elt) l) r in filt Empty s ;; let partition_tf s ~f:p ~compare_elt = let rec part ((t, f) as accu) = function | Empty -> accu | Leaf v -> if p v then (add t v ~compare_elt, f) else (t, add f v ~compare_elt) | Node(l, v, r, _, _) -> part (part ( if p v then (add t v ~compare_elt, f) else (t, add f v ~compare_elt)) l) r in part (Empty, Empty) s ;; let rec elements_aux accu = function | Empty -> accu | Leaf v -> v :: accu | Node(l, v, r, _, _) -> elements_aux (v :: elements_aux accu r) l ;; let elements s = elements_aux [] s let choose t = match t with | Empty -> None | Leaf v -> Some v | Node (_, v, _, _, _) -> Some v ;; let choose_exn t = match choose t with | None -> raise Not_found | Some v -> v ;; let of_list lst ~compare_elt = List.fold lst ~init:empty ~f:(fun t x -> add t x ~compare_elt) ;; let to_list s = elements s let of_array a ~compare_elt = Array.fold a ~init:empty ~f:(fun t x -> add t x ~compare_elt) ;; (* faster but equivalent to [Array.of_list (to_list t)] *) let to_array = function | Empty -> [||] | Leaf v -> [| v |] | Node (l, v, r, _, s) -> let res = Array.create ~len:s v in let pos_ref = ref 0 in let rec loop = function (* Invariant: on entry and on exit to [loop], !pos_ref is the next available cell in the array. *) | Empty -> () | Leaf v -> res.(!pos_ref) <- v; incr pos_ref | Node (l, v, r, _, _) -> loop l; res.(!pos_ref) <- v; incr pos_ref; loop r in loop l; (* res.(!pos_ref) is already initialized (by Array.create ~len:above). *) incr pos_ref; loop r; res ;; let map t ~f ~compare_elt = fold t ~init:empty ~f:(fun t x -> add t (f x) ~compare_elt) let group_by set ~equiv ~compare_elt = let rec loop set equiv_classes = if is_empty set then equiv_classes else let x = choose_exn set in let equiv_x, not_equiv_x = partition_tf set ~f:(fun elt -> x == elt || equiv x elt) ~compare_elt in loop not_equiv_x (equiv_x :: equiv_classes) in loop set [] ;; let rec find t ~f = match t with | Empty -> None | Leaf v -> if f v then Some v else None | Node(l, v, r, _, _) -> if f v then Some v else match find l ~f with | None -> find r ~f | Some _ as r -> r ;; let rec find_map t ~f = match t with | Empty -> None | Leaf v -> f v | Node(l, v, r, _, _) -> match f v with | Some _ as r -> r | None -> match find_map l ~f with | None -> find_map r ~f | Some _ as r -> r ;; let find_exn t ~f = match find t ~f with | None -> failwith "Set.find_exn failed to find a matching element" | Some e -> e ;; let rec find_index t i = match t with | Empty -> None | Leaf v -> if i = 0 then Some v else None | Node (l, v, r, _, s) -> if i >= s then None else begin let l_size = length l in let c = Pervasives.compare i l_size in if c < 0 then find_index l i else if c = 0 then Some v else find_index r (i - l_size - 1) end ;; let stable_dedup_list xs ~compare_elt = let rec loop xs leftovers already_seen = match xs with | [] -> List.rev leftovers | hd :: tl -> if mem already_seen hd ~compare_elt then loop tl leftovers already_seen else loop tl (hd :: leftovers) (add already_seen hd ~compare_elt) in loop xs [] empty ;; let to_map ~comparator t ~f = Map.of_sorted_array_unchecked ~comparator (Array.map (to_array t) ~f:(fun key -> (key, f key))) ;; let of_map_keys m = of_sorted_array_unchecked ~compare_elt:(Map.comparator m).Comparator.compare (List.to_array (Map.keys m)) ;; open Sexplib let t_of_sexp a_of_sexp sexp ~compare_elt = match sexp with | Sexp.List lst -> let elt_lst = List.map lst ~f:a_of_sexp in let set = of_list elt_lst ~compare_elt in if length set = List.length lst then set else let compare (_, e) (_, e') = compare_elt e e' in begin match List.find_a_dup (List.zip_exn lst elt_lst) ~compare with | None -> assert false | Some (el_sexp, _) -> Conv.of_sexp_error "Set.t_of_sexp: duplicate element in set" el_sexp end | sexp -> Conv.of_sexp_error "Set.t_of_sexp: list needed" sexp ;; let sexp_of_t sexp_of_a t = Sexp.List (fold_right t ~init:[] ~f:(fun el acc -> sexp_of_a el :: acc)) ;; end type ('a, 'comparator) t = { (* [comparator] is the first field so that polymorphic comparisons fail on a map due to the functional value in the comparator. *) comparator : ('a, 'comparator) Comparator.t; tree : 'a Tree0.t; } let comparator t = t.comparator type ('a, 'comparator) set = ('a, 'comparator) t type ('a, 'comparator) tree = 'a Tree0.t let like { tree = _; comparator } tree = { tree; comparator } let compare_elt t = t.comparator.Comparator.compare module Accessors = struct let to_tree t = t.tree let invariants t = Tree0.invariants t.tree ~compare_elt:(compare_elt t) let length t = Tree0.length t.tree let is_empty t = Tree0.is_empty t.tree let elements t = Tree0.elements t.tree let min_elt t = Tree0.min_elt t.tree let min_elt_exn t = Tree0.min_elt_exn t.tree let max_elt t = Tree0.max_elt t.tree let max_elt_exn t = Tree0.max_elt_exn t.tree let choose t = Tree0.choose t.tree let choose_exn t = Tree0.choose_exn t.tree let to_list t = Tree0.to_list t.tree let to_array t = Tree0.to_array t.tree let fold t ~init ~f = Tree0.fold t.tree ~init ~f let fold_until t ~init ~f = Tree0.fold_until t.tree ~init ~f let fold_right t ~init ~f = Tree0.fold_right t.tree ~init ~f let iter t ~f = Tree0.iter t.tree ~f let iter2 a b ~f = Tree0.iter2 a.tree b.tree ~f ~compare_elt:(compare_elt a) let exists t ~f = Tree0.exists t.tree ~f let for_all t ~f = Tree0.for_all t.tree ~f let count t ~f = Tree0.count t.tree ~f let sum m t ~f = Tree0.sum m t.tree ~f let find t ~f = Tree0.find t.tree ~f let find_exn t ~f = Tree0.find_exn t.tree ~f let find_map t ~f = Tree0.find_map t.tree ~f let mem t a = Tree0.mem t.tree a ~compare_elt:(compare_elt t) let filter t ~f = like t (Tree0.filter t.tree ~f ~compare_elt:(compare_elt t)) let add t a = like t (Tree0.add t.tree a ~compare_elt:(compare_elt t)) let remove t a = like t (Tree0.remove t.tree a ~compare_elt:(compare_elt t)) let union t1 t2 = like t1 (Tree0.union t1.tree t2.tree ~compare_elt:(compare_elt t1)) let inter t1 t2 = like t1 (Tree0.inter t1.tree t2.tree ~compare_elt:(compare_elt t1)) let diff t1 t2 = like t1 (Tree0.diff t1.tree t2.tree ~compare_elt:(compare_elt t1)) let symmetric_diff t1 t2 = Tree0.symmetric_diff t1.tree t2.tree ~compare_elt:(compare_elt t1) let compare_direct t1 t2 = Tree0.compare (compare_elt t1) t1.tree t2.tree let equal t1 t2 = Tree0.equal t1.tree t2.tree ~compare_elt:(compare_elt t1) let subset t1 t2 = Tree0.subset t1.tree t2.tree ~compare_elt:(compare_elt t1) let partition_tf t ~f = let (tree_t, tree_f) = Tree0.partition_tf t.tree ~f ~compare_elt:(compare_elt t) in like t tree_t, like t tree_f ;; let split t a = let (tree1, b, tree2) = Tree0.split t.tree a ~compare_elt:(compare_elt t) in like t tree1, b, like t tree2 ;; let group_by t ~equiv = List.map (Tree0.group_by t.tree ~equiv ~compare_elt:(compare_elt t)) ~f:(like t) ;; let find_index t i = Tree0.find_index t.tree i let remove_index t i = like t (Tree0.remove_index t.tree i ~compare_elt:(compare_elt t)) let sexp_of_t sexp_of_a t = Tree0.sexp_of_t sexp_of_a t.tree let to_sequence ?order ?greater_or_equal_to ?less_or_equal_to t = Tree0.to_sequence t.comparator ?order ?greater_or_equal_to ?less_or_equal_to t.tree let to_map t ~f = Tree0.to_map t.tree ~f ~comparator:t.comparator end let to_tree t = t.tree let of_tree ~comparator tree = { comparator; tree } let empty ~comparator = { comparator; tree = Tree0.empty } let singleton ~comparator e = { comparator; tree = Tree0.singleton e } let union_list ~comparator l = of_tree ~comparator (Tree0.union_list ~comparator ~to_tree l) ;; let of_sorted_array_unchecked ~comparator array = let tree = Tree0.of_sorted_array_unchecked array ~compare_elt:comparator.Comparator.compare in { comparator; tree } ;; let of_sorted_array ~comparator array = Or_error.Monad_infix.( Tree0.of_sorted_array array ~compare_elt:comparator.Comparator.compare >>| fun tree -> { comparator; tree }) ;; let of_list ~comparator l = { comparator; tree = Tree0.of_list l ~compare_elt:comparator.Comparator.compare } ;; let of_array ~comparator a = { comparator; tree = Tree0.of_array a ~compare_elt:comparator.Comparator.compare } ;; let stable_dedup_list ~comparator xs = Tree0.stable_dedup_list xs ~compare_elt:comparator.Comparator.compare; ;; let map ~comparator t ~f = { comparator; tree = Tree0.map t.tree ~f ~compare_elt:comparator.Comparator.compare } ;; let filter_map ~comparator t ~f = { comparator; tree = Tree0.filter_map t.tree ~f ~compare_elt:comparator.Comparator.compare; } ;; let of_map_keys m = { comparator = Map.comparator m; tree = Tree0.of_map_keys m } include Accessors let compare _ _ t1 t2 = compare_direct t1 t2 module Creators (Elt : Comparator.S1) : sig type ('a, 'comparator) t_ = ('a Elt.t, Elt.comparator_witness) set type ('a, 'b) tree = 'a Tree0.t type 'a elt_ = 'a Elt.t type 'a cmp_ = Elt.comparator_witness val t_of_sexp : (Sexp.t -> 'a Elt.t) -> Sexp.t -> ('a, 'comparator) t_ include Creators_generic with type ('a, 'b) t := ('a, 'b) t_ with type ('a, 'b) set := ('a, 'b) set with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a elt_ with type ('a, 'b, 'c) options := ('a, 'b, 'c) Without_comparator.t with type 'a cmp := 'a cmp_ end = struct type ('a, 'comparator) t_ = ('a Elt.t, Elt.comparator_witness) set type ('a, 'b) tree = 'a Tree0.t type 'a elt_ = 'a Elt.t type 'cmp cmp_ = Elt.comparator_witness let comparator = Elt.comparator let compare_elt = comparator.Comparator.compare let of_tree tree = of_tree ~comparator tree let of_sorted_array_unchecked array = of_sorted_array_unchecked ~comparator array let of_sorted_array array = of_sorted_array ~comparator array let empty = { comparator; tree = Tree0.empty } let singleton e = singleton ~comparator e let union_list l = union_list ~comparator l let of_list l = of_list ~comparator l let of_array a = of_array ~comparator a let stable_dedup_list xs = stable_dedup_list ~comparator xs let map t ~f = map ~comparator t ~f let filter_map t ~f = filter_map ~comparator t ~f let t_of_sexp a_of_sexp sexp = of_tree (Tree0.t_of_sexp a_of_sexp sexp ~compare_elt) let of_map_keys = of_map_keys end module Make_tree (Elt : Comparator.S1) = struct let comparator = Elt.comparator let compare_elt = comparator.Comparator.compare let empty = Tree0.empty let singleton e = Tree0.singleton e let invariants t = Tree0.invariants t ~compare_elt let length t = Tree0.length t let is_empty t = Tree0.is_empty t let elements t = Tree0.elements t let min_elt t = Tree0.min_elt t let min_elt_exn t = Tree0.min_elt_exn t let max_elt t = Tree0.max_elt t let max_elt_exn t = Tree0.max_elt_exn t let choose t = Tree0.choose t let choose_exn t = Tree0.choose_exn t let to_list t = Tree0.to_list t let to_array t = Tree0.to_array t let iter t ~f = Tree0.iter t ~f let iter2 a b ~f = Tree0.iter2 a b ~f ~compare_elt let exists t ~f = Tree0.exists t ~f let for_all t ~f = Tree0.for_all t ~f let count t ~f = Tree0.count t ~f let sum m t ~f = Tree0.sum m t ~f let find t ~f = Tree0.find t ~f let find_exn t ~f = Tree0.find_exn t ~f let find_map t ~f = Tree0.find_map t ~f let fold t ~init ~f = Tree0.fold t ~init ~f let fold_until t ~init ~f = Tree0.fold_until t ~init ~f let fold_right t ~init ~f = Tree0.fold_right t ~init ~f let map t ~f = Tree0.map t ~f ~compare_elt let filter t ~f = Tree0.filter t ~f ~compare_elt let filter_map t ~f = Tree0.filter_map t ~f ~compare_elt let partition_tf t ~f = Tree0.partition_tf t ~f ~compare_elt let mem t a = Tree0.mem t a ~compare_elt let add t a = Tree0.add t a ~compare_elt let remove t a = Tree0.remove t a ~compare_elt let union t1 t2 = Tree0.union t1 t2 ~compare_elt let inter t1 t2 = Tree0.inter t1 t2 ~compare_elt let diff t1 t2 = Tree0.diff t1 t2 ~compare_elt let symmetric_diff t1 t2 = Tree0.symmetric_diff t1 t2 ~compare_elt let compare_direct t1 t2 = Tree0.compare compare_elt t1 t2 let equal t1 t2 = Tree0.equal t1 t2 ~compare_elt let subset t1 t2 = Tree0.subset t1 t2 ~compare_elt let of_list l = Tree0.of_list l ~compare_elt let of_array a = Tree0.of_array a ~compare_elt let of_sorted_array_unchecked a = Tree0.of_sorted_array_unchecked a ~compare_elt let of_sorted_array a = Tree0.of_sorted_array a ~compare_elt let union_list l = Tree0.union_list l ~comparator ~to_tree:Fn.id let stable_dedup_list xs = Tree0.stable_dedup_list xs ~compare_elt let group_by t ~equiv = Tree0.group_by t ~equiv ~compare_elt let split t a = Tree0.split t a ~compare_elt let find_index t i = Tree0.find_index t i let remove_index t i = Tree0.remove_index t i ~compare_elt let to_tree t = t let of_tree t = t let to_sequence ?order ?greater_or_equal_to ?less_or_equal_to t = Tree0.to_sequence comparator ?order ?greater_or_equal_to ?less_or_equal_to t let of_map_keys = Tree0.of_map_keys let to_map t ~f = Tree0.to_map t ~f ~comparator end module Poly = struct module Elt = Comparator.Poly include Creators (Elt) type 'a t = ('a, Elt.comparator_witness) set include Accessors let compare _ t1 t2 = compare_direct t1 t2 let sexp_of_t = sexp_of_t include Bin_prot.Utils.Make_iterable_binable1 (struct type 'a t = ('a, Elt.comparator_witness) set type 'a acc = 'a t type 'a el = 'a with bin_io let _ = bin_el let module_name = Some "Core_kernel.Std.Set" let length = length let iter t ~f = iter ~f:(fun key -> f key) t let init _n = empty let insert acc el _i = if mem acc el then failwith "Set.bin_read_t_: duplicate element in set" else add acc el ;; let finish t = t end) module Tree = struct include Make_tree (Comparator.Poly) type 'elt t = ('elt, Comparator.Poly.comparator_witness) tree let sexp_of_t sexp_of_elt t = Tree0.sexp_of_t sexp_of_elt t let t_of_sexp elt_of_sexp sexp = Tree0.t_of_sexp elt_of_sexp sexp ~compare_elt:Comparator.Poly.comparator.Comparator.compare ;; end TEST_MODULE = struct let (=) = Pervasives.(=) TEST = stable_dedup_list [] = [] TEST = stable_dedup_list [5;5;5;5;5] = [5] TEST = stable_dedup_list [5;9;3;5;2;2] = [5;9;3;2] end end module type S = S0 with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree module type S_binable = S0_binable with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree module Make_using_comparator (Elt : sig type t with sexp include Comparator.S with type t := t end) = struct module Elt = Elt module Elt_S1 = Comparator.S_to_S1 (Elt) include Creators (Elt_S1) type ('a, 'b) set = ('a, 'b) t type t = (Elt.t, Elt.comparator_witness) set include Accessors let compare t1 t2 = compare_direct t1 t2 let sexp_of_t t = sexp_of_t Elt.sexp_of_t t let t_of_sexp sexp = t_of_sexp Elt.t_of_sexp sexp module Tree = struct include Make_tree (Elt_S1) type t = (Elt.t, Elt.comparator_witness) tree let compare t1 t2 = compare_direct t1 t2 let sexp_of_t t = Tree0.sexp_of_t Elt.sexp_of_t t let t_of_sexp sexp = Tree0.t_of_sexp Elt.t_of_sexp sexp ~compare_elt:Elt_S1.comparator.Comparator.compare ;; end end module Make (Elt : Elt) = Make_using_comparator (struct include Elt include Comparator.Make (Elt) end) module Make_binable_using_comparator (Elt' : sig type t with bin_io, sexp include Comparator.S with type t := t end) = struct include (Make_using_comparator (Elt')) include Bin_prot.Utils.Make_iterable_binable (struct type acc = t type t = acc type el = Elt'.t with bin_io let _ = bin_el let module_name = Some "Core_kernel.Std.Set" let length = length let iter t ~f = iter ~f:(fun key -> f key) t let init _n = empty let insert acc el _i = if mem acc el then failwith "Set.bin_read_t_: duplicate element in set" else add acc el ;; let finish t = t end) end module Make_binable (Elt : Elt_binable) = Make_binable_using_comparator (struct include Elt include Comparator.Make (Elt) end) module Tree = struct type ('a, 'comparator) t = ('a, 'comparator) tree let ce comparator = comparator.Comparator.compare let empty ~comparator:_ = Tree0.empty let singleton ~comparator:_ e = Tree0.singleton e let length t = Tree0.length t let invariants ~comparator t = Tree0.invariants t ~compare_elt:(ce comparator) let is_empty t = Tree0.is_empty t let elements t = Tree0.elements t let min_elt t = Tree0.min_elt t let min_elt_exn t = Tree0.min_elt_exn t let max_elt t = Tree0.max_elt t let max_elt_exn t = Tree0.max_elt_exn t let choose t = Tree0.choose t let choose_exn t = Tree0.choose_exn t let to_list t = Tree0.to_list t let to_array t = Tree0.to_array t let iter t ~f = Tree0.iter t ~f let exists t ~f = Tree0.exists t ~f let for_all t ~f = Tree0.for_all t ~f let count t ~f = Tree0.count t ~f let sum m t ~f = Tree0.sum m t ~f let find t ~f = Tree0.find t ~f let find_exn t ~f = Tree0.find_exn t ~f let find_map t ~f = Tree0.find_map t ~f let fold t ~init ~f = Tree0.fold t ~init ~f let fold_until t ~init ~f = Tree0.fold_until t ~init ~f let fold_right t ~init ~f = Tree0.fold_right t ~init ~f let map ~comparator t ~f = Tree0.map t ~f ~compare_elt:(ce comparator) let filter ~comparator t ~f = Tree0.filter t ~f ~compare_elt:(ce comparator) let filter_map ~comparator t ~f = Tree0.filter_map t ~f ~compare_elt:(ce comparator) let partition_tf ~comparator t ~f = Tree0.partition_tf t ~f ~compare_elt:(ce comparator) let iter2 ~comparator a b ~f = Tree0.iter2 a b ~f ~compare_elt:(ce comparator) let mem ~comparator t a = Tree0.mem t a ~compare_elt:(ce comparator) let add ~comparator t a = Tree0.add t a ~compare_elt:(ce comparator) let remove ~comparator t a = Tree0.remove t a ~compare_elt:(ce comparator) let union ~comparator t1 t2 = Tree0.union t1 t2 ~compare_elt:(ce comparator) let inter ~comparator t1 t2 = Tree0.inter t1 t2 ~compare_elt:(ce comparator) let diff ~comparator t1 t2 = Tree0.diff t1 t2 ~compare_elt:(ce comparator) let symmetric_diff ~comparator t1 t2 = Tree0.symmetric_diff t1 t2 ~compare_elt:(ce comparator) let compare_direct ~comparator t1 t2 = Tree0.compare (ce comparator) t1 t2 let equal ~comparator t1 t2 = Tree0.equal t1 t2 ~compare_elt:(ce comparator) let subset ~comparator t1 t2 = Tree0.subset t1 t2 ~compare_elt:(ce comparator) let of_list ~comparator l = Tree0.of_list l ~compare_elt:(ce comparator) let of_array ~comparator a = Tree0.of_array a ~compare_elt:(ce comparator) let of_sorted_array_unchecked ~comparator a = Tree0.of_sorted_array_unchecked a ~compare_elt:(ce comparator) let of_sorted_array ~comparator a = Tree0.of_sorted_array a ~compare_elt:(ce comparator) let union_list ~comparator l = Tree0.union_list l ~to_tree:Fn.id ~comparator let stable_dedup_list ~comparator xs = Tree0.stable_dedup_list xs ~compare_elt:(ce comparator) ;; let group_by ~comparator t ~equiv = Tree0.group_by t ~equiv ~compare_elt:(ce comparator) let split ~comparator t a = Tree0.split t a ~compare_elt:(ce comparator) let find_index t i = Tree0.find_index t i let remove_index ~comparator t i = Tree0.remove_index t i ~compare_elt:(ce comparator) let sexp_of_t sexp_of_a _ t = Tree0.sexp_of_t sexp_of_a t let to_tree t = t let of_tree ~comparator:_ t = t let to_sequence ~comparator ?order ?greater_or_equal_to ?less_or_equal_to t = Tree0.to_sequence comparator ?order ?greater_or_equal_to ?less_or_equal_to t let of_map_keys = Tree0.of_map_keys let to_map = Tree0.to_map end core_kernel-113.00.00/src/core_set.mli000066400000000000000000000340461256461164500174220ustar00rootroot00000000000000(** This module defines the [Set] module for [Core.Std]. We use "core_set" as the file name rather than "set" to avoid conflicts with OCaml's standard set module. This module uses the same organizational approach as [Core_map]. See the documentation in core_map.mli for a description of the approach. Functions that construct a set take as an argument the comparator for the element type. *) open Core_set_intf (** The type of a set. The first type parameter identifies the type of the element, and the second identifies the comparator, which determines the comparison function that is used for ordering elements in this set. Many operations (e.g., {!union}), require that they be passed sets with the same element type and the same comparator type. *) type ('elt, 'cmp) t with compare module Tree : sig (** A [Tree.t] contains just the tree data structure that a set is based on, without including the comparator. Accordingly, any operation on a [Tree.t] must also take as an argument the corresponding comparator. *) type ('a, 'cmp) t with sexp_of include Creators_and_accessors2_with_comparator with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) t end (** Tests internal invariants of the set data structure. Returns true on success. *) val invariants : (_, _) t -> bool val comparator : ('a, 'cmp) t -> ('a, 'cmp) Comparator.t (** Creates an empty set based on the provided comparator. *) val empty : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t (** Creates a set based on the provided comparator that contains only the provided element. *) val singleton : comparator:('a, 'cmp) Comparator.t -> 'a -> ('a, 'cmp) t (** Returns the number of elements in the set. [O(1)]. *) val length : (_, _) t -> int (** [is_empty t] is [true] iff [t] is empty. [O(1)]. *) val is_empty : (_, _) t -> bool (** [mem t a] returns [true] iff [a] is in [t]. [O(log n)]. *) val mem : ('a, _) t -> 'a -> bool (** [add t a] returns a new set with [a] added to [t], or returns [t] if [mem t a]. [O(log n)]. *) val add : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t (** [remove t a] returns a new set with [a] removed from [t] if [mem t a], or returns [t] otherwise. [O(log n)]. *) val remove : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t (** [union t1 t2] returns the union of the two sets. [O(length t1 + length t2)]. *) val union : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [union ~comparator list] returns the union of all the sets in [list]. The [comparator] argument is required for the case where [list] is empty. [O(max(List.length list, n log n))], where [n] is the sum of sizes of the input sets. *) val union_list : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t list -> ('a, 'cmp) t (** [inter t1 t2] computes the intersection of sets [t1] and [t2]. [O(log(length t1) + log(length t2))]. *) val inter : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [diff t1 t2] computes the set difference [t1 - t2], i.e., the set containing all elements in [t1] that are not in [t2]. [O(log(length t1) + log(length t2))]. *) val diff : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t (** [symmetric_diff t1 t2] returns a sequence of changes between [t1] and [t2]. It is intended to be efficient in the case where [t1] and [t2] share a large amount of structure. *) val symmetric_diff : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'a) Either.t Sequence.t (** [compare_direct t1 t2] compares the sets [t1] and [t2]. It returns the same result as [compare], but unlike compare, doesn't require arguments to be passed in for the type parameters of the set. [O(length t1 + length t2)]. *) val compare_direct : ('a, 'cmp) t -> ('a, 'cmp) t -> int (** [equal t1 t2] returns [true] iff the two sets have the same elements. [O(length t1 + length t2)] *) val equal : ('a, 'cmp) t -> ('a, 'cmp) t -> bool (** [exists t ~f] returns [true] iff there exists an [a] in [t] for which [f a]. [O(n)], but returns as soon as it finds an [a] for which [f a]. *) val exists : ('a, _) t -> f:('a -> bool) -> bool (** [for_all t ~f] returns [true] iff for all [a] in [t], [f a]. [O(n)], but returns as soon as it finds an [a] for which [not (f a)]. *) val for_all : ('a, _) t -> f:('a -> bool) -> bool (** [count t] returns the number of elements of [t] for which [f] returns [true]. [O(n)]. *) val count : ('a, _) t -> f:('a -> bool) -> int (** [sum t] returns the sum of [f t] for each [t] in the set. [O(n)]. *) val sum : (module Commutative_group.S with type t = 'sum) -> ('a, _) t -> f:('a -> 'sum) -> 'sum (** [find t f] returns an element of [t] for which [f] returns true, with no guarantee as to which element is returned. [O(n)], but returns as soon as a suitable element is found. *) val find : ('a, _) t -> f:('a -> bool) -> 'a option (** [find_map t f] returns [b] for some [a] in [t] for which [f a = Some b]. If no such [a] exists, then [find] returns [None]. [O(n)], but returns as soon as a suitable element is found. *) val find_map : ('a, _) t -> f:('a -> 'b option) -> 'b option (** Like [find], but throws an exception on failure. *) val find_exn : ('a, _) t -> f:('a -> bool) -> 'a (** [find_index t i] returns the [i]th smallest element of [t], in [O(log n)] time. The smallest element has [i = 0]. Returns [None] if [i < 0] or [i >= length t]. *) val find_index : ('a, _) t -> int -> 'a option (** [remove_index t i] returns a version of [t] with the [i]th smallest element removed, in [O(log n)] time. The smallest element has [i = 0]. Returns [t] if [i < 0] or [i >= length t]. *) val remove_index : ('a, 'cmp) t -> int -> ('a, 'cmp) t (** [subset t1 t2] returns true iff [t1] is a subset of [t2]. *) val subset : ('a, 'cmp) t -> ('a, 'cmp) t -> bool (** The list or array given to [of_list] and [of_array] need not be sorted. *) val of_list : comparator:('a, 'cmp) Comparator.t -> 'a list -> ('a, 'cmp) t val of_array : comparator:('a, 'cmp) Comparator.t -> 'a array -> ('a, 'cmp) t (** [to_list] and [to_array] produce sequences sorted in ascending order according to the comparator. *) val to_list : ('a, _) t -> 'a list val to_array : ('a, _) t -> 'a array val to_tree : ('a, 'cmp) t -> ('a, 'cmp) Tree.t val of_tree : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) Tree.t -> ('a, 'cmp) t (** Create set from sorted array. The input must be sorted (either in ascending or descending order as given by the comparator) and contain no duplicates, otherwise the result is an error. The complexity of this function is [O(n)]. *) val of_sorted_array : comparator:('a, 'cmp) Comparator.t -> 'a array -> ('a, 'cmp) t Or_error.t (** Similar to [of_sorted_array], but without checking the input array. *) val of_sorted_array_unchecked : comparator:('a, 'cmp) Comparator.t -> 'a array -> ('a, 'cmp) t (** [stable_dedup_list] is here rather than in the [List] module because the implementation relies crucially on sets, and because doing so allows one to avoid uses of polymorphic comparison by instantiating the functor at a different implementation of [Comparator] and using the resulting [stable_dedup_list]. *) val stable_dedup_list : comparator:('a, _) Comparator.t -> 'a list -> 'a list (** [map ~comparator t ~f] returns a new set created by applying [f] to every element in [t]. The returned set is based on the provided [comparator]. [O(n log n)]. *) val map : comparator:('b, 'cmp) Comparator.t -> ('a, _) t -> f:('a -> 'b) -> ('b, 'cmp) t (** Like {!map}, except elements for which [f] returns [None] will be dropped. *) val filter_map : comparator:('b, 'cmp) Comparator.t -> ('a, _) t -> f:('a -> 'b option) -> ('b, 'cmp) t (** [filter t ~f] returns the subset of [t] for which [f] evaluates to true. [O(n log n)]. *) val filter : ('a, 'cmp) t -> f:('a -> bool) -> ('a, 'cmp) t (** [fold t ~init ~f] folds over the elements of the set from smallest to largest. *) val fold : ('a, _) t -> init:'accum -> f:('accum -> 'a -> 'accum) -> 'accum (** Like {!fold}, except that it will terminate early, if [f] returns [`Stop]. *) val fold_until : ('a, _) t -> init:'accum -> f:('accum -> 'a -> [ `Continue of 'accum | `Stop of 'accum ]) -> 'accum (** Like {!fold}, except that it goes from the largest to the smallest element. *) val fold_right : ('a, _) t -> init:'accum -> f:('a -> 'accum -> 'accum) -> 'accum (** [iter t ~f] calls [f] on every element of [t], going in order from the smallest to largest. *) val iter : ('a, _) t -> f:('a -> unit) -> unit (** Iterate two sets side by side. Complexity is [O(m+n)] where [m] and [n] are the sizes of the two input sets. As an example, with the inputs [0; 1] and [1; 2], [f] will be called with [`Left 0]; [`Both (1, 1)]; and [`Right 2]. *) val iter2 : ('a, 'cmp) t -> ('a, 'cmp) t -> f:([`Left of 'a | `Right of 'a | `Both of 'a * 'a] -> unit) -> unit (** if [a, b = partition_tf set ~f] then [a] is the elements on which [f] produced [true], and [b] is the elements on which [f] produces [false]. *) val partition_tf : ('a, 'cmp) t -> f:('a -> bool) -> ('a, 'cmp) t * ('a, 'cmp) t (** Same as {!to_list}. *) val elements : ('a, _) t -> 'a list (** Returns the smallest element of the set. [O(log n)]. *) val min_elt : ('a, _) t -> 'a option (** Like {!min_elt}, but throws an exception when given an empty set. *) val min_elt_exn : ('a, _) t -> 'a (** Returns the largest element of the set. [O(log n)]. *) val max_elt : ('a, _) t -> 'a option (** Like {!max_elt}, but throws an exception when given an empty set. *) val max_elt_exn : ('a, _) t -> 'a (** returns an arbitrary element, or [None] if the set is empty. *) val choose : ('a, _) t -> 'a option (** Like {!choose}, but throws an exception on an empty set. *) val choose_exn : ('a, _) t -> 'a (** [split t x] produces a triple [(t1, maybe_x, t2)] where [t1] is the set of elements strictly less than [x], [maybe_x] is the member (if any) of [t] which compares equal to [x], and [t2] is the set of elements strictly larger than [x]. *) val split : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t * 'a option * ('a, 'cmp) t (** if [equiv] is an equivalence predicate, then [group_by set ~equiv] produces a list of equivalence classes (i.e., a set-theoretic quotient). E.g., {[ let chars = Set.of_list ['A'; 'a'; 'b'; 'c'] in let equiv c c' = Char.equal (Char.uppercase c) (Char.uppercase c') in group_by chars ~equiv ]} produces: {[ Set.of_list['A';'a']; Set.singleton 'b'; Set.singleton 'c'] ]} [group_by] runs in O(n^2) time, so if you have a comparison function, it's usually much faster to use [Set.of_list]. *) val group_by : ('a, 'cmp) t -> equiv:('a -> 'a -> bool) -> ('a, 'cmp) t list (** [to_sequence t] converts the set [t] to a sequence of the elements between [greater_or_equal_to] and [less_or_equal_to] inclusive in the order indicated by [order]. If [greater_or_equal_to > less_or_equal_to] the sequence is empty. Cost is O(log n) up front and amortized O(1) for each element produced. *) val to_sequence : ?order : [ `Increasing (** default *) | `Decreasing ] -> ?greater_or_equal_to : 'a -> ?less_or_equal_to : 'a -> ('a, 'cmp) t -> 'a Sequence.t (** Convert a set to or from a map. [to_map] takes a function to produce data for each key. Both functions run in O(n) time (assuming the function passed to [to_map] runs in constant time). *) val to_map : ('key, 'cmp) t -> f:('key -> 'data) -> ('key, 'data, 'cmp) Map.t val of_map_keys : ('key, _, 'cmp) Map.t -> ('key, 'cmp) t (** {1 Polymorphic sets} Module {!Poly} deals with sets that use OCaml's polymorphic comparison to compare elements. *) module Poly : sig type ('a, 'b) set module Tree : sig type 'elt t = ('elt, Comparator.Poly.comparator_witness) Tree.t with sexp include Creators_and_accessors1 with type ('a, 'b) set := ('a, 'b) Tree.t with type 'elt t := 'elt t with type 'elt tree := 'elt t with type comparator_witness := Comparator.Poly.comparator_witness end type 'elt t = ('elt, Comparator.Poly.comparator_witness) set with bin_io, compare, sexp include Creators_and_accessors1 with type ('a, 'b) set := ('a, 'b) set with type 'elt t := 'elt t with type 'elt tree := 'elt Tree.t with type comparator_witness := Comparator.Poly.comparator_witness end with type ('a, 'b) set := ('a, 'b) t (** {1 Signatures and functors for building [Set] modules} *) (** The signature that something needs to match in order to be used as a set element. *) module type Elt = Elt (** The signature that something needs to match in order to be used as a set element if the resulting set is going to support [bin_io]. *) module type Elt_binable = Elt_binable (** Module signature for a Set. *) module type S = S0 with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t (** Module signature for a Set that supports [bin_io]. *) module type S_binable = S0_binable with type ('a, 'b) set := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) Tree.t (** [Make] builds a set from an element type that has a [compare] function but doesn't have a comparator. This generates a new comparator. [Make_binable] is similar, except the element and set types support [bin_io]. *) module Make (Elt : Elt) : S with type Elt.t = Elt.t module Make_binable (Elt : Elt_binable) : S_binable with type Elt.t = Elt.t (** [Make_using_comparator] builds a set from an element type that has a comparator. [Make_binable_using_comparator] is similar, except the element and set types support [bin_io]. *) module Make_using_comparator (Elt : sig type t with sexp include Comparator.S with type t := t end) : S with type Elt.t = Elt.t with type Elt.comparator_witness = Elt.comparator_witness module Make_binable_using_comparator (Elt : sig type t with bin_io, sexp include Comparator.S with type t := t end) : S_binable with type Elt.t = Elt.t with type Elt.comparator_witness = Elt.comparator_witness core_kernel-113.00.00/src/core_set_intf.ml000066400000000000000000000555711256461164500202770ustar00rootroot00000000000000(** This module defines interfaces used in [Core.Std.Set]. This module uses the same organizational approach as [Core_map_intf]. See the documentation in core_map.mli for a description of the approach. This module defines module types [{Creators,Accessors}{0,1,2,_generic,_with_comparator}]. It uses check functors to ensure that each module types is an instance of the corresponding [_generic] one. We must treat [Creators] and [Accessors] separately, because we sometimes need to choose different instantiations of their [options]. In particular, [Set] itself matches [Creators2_with_comparator] but [Accessors2] (without comparator). *) (* CRs and comments about [Set] functions do not belong in this file. They belong next to the appropriate function in core_set.mli. *) open T module Binable = Binable0 module type Elt = sig type t with compare, sexp end module type Elt_binable = sig type t with bin_io, compare, sexp end module Without_comparator = Core_map_intf.Without_comparator module With_comparator = Core_map_intf.With_comparator module Map = Core_map module type Accessors_generic = sig include Container.Generic_phantom type ('a, 'cmp) tree (** The [options] type is used to make [Accessors_generic] flexible as to whether a comparator is required to be passed to certain functions. *) type ('a, 'cmp, 'z) options type 'cmp cmp val invariants : ('a, 'cmp, ('a, 'cmp) t -> bool ) options (** override [Container]'s [mem] *) val mem : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> bool) options val add : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> ('a, 'cmp) t ) options val remove : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> ('a, 'cmp) t ) options val union : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t ) options val inter : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t ) options val diff : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t ) options val symmetric_diff : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> ('a elt, 'a elt) Either.t Sequence.t ) options val compare_direct : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> int ) options val equal : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> bool ) options val subset : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> bool ) options val fold_until : ('a, _) t -> init:'b -> f:('b -> 'a elt -> [ `Continue of 'b | `Stop of 'b ]) -> 'b val fold_right : ('a, _) t -> init:'b -> f:('a elt -> 'b -> 'b) -> 'b val iter2 : ('a, 'cmp, ('a, 'cmp) t -> ('a, 'cmp) t -> f:([ `Left of 'a elt | `Right of 'a elt | `Both of 'a elt * 'a elt ] -> unit) -> unit ) options val filter : ('a, 'cmp, ('a, 'cmp) t -> f:('a elt -> bool) -> ('a, 'cmp) t ) options val partition_tf : ('a, 'cmp, ('a, 'cmp) t -> f:('a elt -> bool) -> ('a, 'cmp) t * ('a, 'cmp) t ) options val elements : ('a, _) t -> 'a elt list val min_elt : ('a, _) t -> 'a elt option val min_elt_exn : ('a, _) t -> 'a elt val max_elt : ('a, _) t -> 'a elt option val max_elt_exn : ('a, _) t -> 'a elt val choose : ('a, _) t -> 'a elt option val choose_exn : ('a, _) t -> 'a elt val split : ('a, 'cmp, ('a, 'cmp) t -> 'a elt -> ('a, 'cmp) t * 'a elt option * ('a, 'cmp) t ) options val group_by : ('a, 'cmp, ('a, 'cmp) t -> equiv:('a elt -> 'a elt -> bool) -> ('a, 'cmp) t list ) options val find_exn : ('a, _) t -> f:('a elt -> bool) -> 'a elt val find_index : ('a, _) t -> int -> 'a elt option val remove_index : ('a, 'cmp, ('a, 'cmp) t -> int -> ('a, 'cmp) t ) options val to_tree : ('a, 'cmp) t -> ('a elt, 'cmp) tree val to_sequence : ('a, 'cmp, ?order:[ `Increasing | `Decreasing ] -> ?greater_or_equal_to:'a elt -> ?less_or_equal_to:'a elt -> ('a, 'cmp) t -> 'a elt Sequence.t ) options val to_map : ('a, 'cmp, ('a, 'cmp) t -> f:('a elt -> 'b) -> ('a elt, 'b, 'cmp cmp) Map.t ) options end module type Accessors0 = sig include Container.S0 type tree type comparator_witness val invariants : t -> bool val mem : t -> elt -> bool val add : t -> elt -> t val remove : t -> elt -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val symmetric_diff : t -> t -> (elt, elt) Either.t Sequence.t val compare_direct : t -> t -> int val equal : t -> t -> bool val subset : t -> t -> bool val fold_until : t -> init:'b -> f:('b -> elt -> [ `Continue of 'b | `Stop of 'b ]) -> 'b val fold_right : t -> init:'b -> f:(elt -> 'b -> 'b) -> 'b val iter2 : t -> t -> f:([ `Left of elt | `Right of elt | `Both of elt * elt ] -> unit) -> unit val filter : t -> f:(elt -> bool) -> t val partition_tf : t -> f:(elt -> bool) -> t * t val elements : t -> elt list val min_elt : t -> elt option val min_elt_exn : t -> elt val max_elt : t -> elt option val max_elt_exn : t -> elt val choose : t -> elt option val choose_exn : t -> elt val split : t -> elt -> t * elt option * t val group_by : t -> equiv:(elt -> elt -> bool) -> t list val find_exn : t -> f:(elt -> bool) -> elt val find_index : t -> int -> elt option val remove_index : t -> int -> t val to_tree : t -> tree val to_sequence : ?order:[ `Increasing | `Decreasing ] -> ?greater_or_equal_to:elt -> ?less_or_equal_to:elt -> t -> elt Sequence.t val to_map : t -> f:(elt -> 'data) -> (elt, 'data, comparator_witness) Map.t end module type Accessors1 = sig include Container.S1 type 'a tree type comparator_witness val invariants : _ t -> bool val mem : 'a t -> 'a -> bool val add : 'a t -> 'a -> 'a t val remove : 'a t -> 'a -> 'a t val union : 'a t -> 'a t -> 'a t val inter : 'a t -> 'a t -> 'a t val diff : 'a t -> 'a t -> 'a t val symmetric_diff : 'a t -> 'a t -> ('a, 'a) Either.t Sequence.t val compare_direct : 'a t -> 'a t -> int val equal : 'a t -> 'a t -> bool val subset : 'a t -> 'a t -> bool val fold_until : 'a t -> init:'b -> f:('b -> 'a -> [ `Continue of 'b | `Stop of 'b ]) -> 'b val fold_right : 'a t -> init:'b -> f:('a -> 'b -> 'b) -> 'b val iter2 : 'a t -> 'a t -> f:([ `Left of 'a | `Right of 'a | `Both of 'a * 'a ] -> unit) -> unit val filter : 'a t -> f:('a -> bool) -> 'a t val partition_tf : 'a t -> f:('a -> bool) -> 'a t * 'a t val elements : 'a t -> 'a list val min_elt : 'a t -> 'a option val min_elt_exn : 'a t -> 'a val max_elt : 'a t -> 'a option val max_elt_exn : 'a t -> 'a val choose : 'a t -> 'a option val choose_exn : 'a t -> 'a val split : 'a t -> 'a -> 'a t * 'a option * 'a t val group_by : 'a t -> equiv:('a -> 'a -> bool) -> 'a t list val find_exn : 'a t -> f:('a -> bool) -> 'a val find_index : 'a t -> int -> 'a option val remove_index : 'a t -> int -> 'a t val to_tree : 'a t -> 'a tree val to_sequence : ?order:[ `Increasing | `Decreasing ] -> ?greater_or_equal_to:'a -> ?less_or_equal_to:'a -> 'a t -> 'a Sequence.t val to_map : 'a t -> f:('a -> 'b) -> ('a, 'b, comparator_witness) Map.t end module type Accessors2 = sig include Container.S1_phantom_invariant type ('a, 'cmp) tree val invariants : (_, _) t -> bool val mem : ('a, _) t -> 'a -> bool val add : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t val remove : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t val union : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t val inter : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t val diff : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t val symmetric_diff : ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'a) Either.t Sequence.t val compare_direct : ('a, 'cmp) t -> ('a, 'cmp) t -> int val equal : ('a, 'cmp) t -> ('a, 'cmp) t -> bool val subset : ('a, 'cmp) t -> ('a, 'cmp) t -> bool val fold_until : ('a, _) t -> init:'b -> f:('b -> 'a -> [ `Continue of 'b | `Stop of 'b ]) -> 'b val fold_right : ('a, _) t -> init:'b -> f:('a -> 'b -> 'b) -> 'b val iter2 : ('a, 'cmp) t -> ('a, 'cmp) t -> f:([ `Left of 'a | `Right of 'a | `Both of 'a * 'a ] -> unit) -> unit val filter : ('a, 'cmp) t -> f:('a -> bool) -> ('a, 'cmp) t val partition_tf : ('a, 'cmp) t -> f:('a -> bool) -> ('a, 'cmp) t * ('a, 'cmp) t val elements : ('a, _) t -> 'a list val min_elt : ('a, _) t -> 'a option val min_elt_exn : ('a, _) t -> 'a val max_elt : ('a, _) t -> 'a option val max_elt_exn : ('a, _) t -> 'a val choose : ('a, _) t -> 'a option val choose_exn : ('a, _) t -> 'a val split : ('a, 'cmp) t -> 'a -> ('a, 'cmp) t * 'a option * ('a, 'cmp) t val group_by : ('a, 'cmp) t -> equiv:('a -> 'a -> bool) -> ('a, 'cmp) t list val find_exn : ('a, _) t -> f:('a -> bool) -> 'a val find_index : ('a, _) t -> int -> 'a option val remove_index : ('a, 'cmp) t -> int -> ('a, 'cmp) t val to_tree : ('a, 'cmp) t -> ('a, 'cmp) tree val to_sequence : ?order:[ `Increasing | `Decreasing ] -> ?greater_or_equal_to:'a -> ?less_or_equal_to:'a -> ('a, 'cmp) t -> 'a Sequence.t val to_map : ('a, 'cmp) t -> f:('a -> 'b) -> ('a, 'b, 'cmp) Map.t end module type Accessors2_with_comparator = sig include Container.S1_phantom_invariant type ('a, 'cmp) tree val invariants : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> bool val mem : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> 'a -> bool val add : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> 'a -> ('a, 'cmp) t val remove : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> 'a -> ('a, 'cmp) t val union : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t val inter : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t val diff : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> ('a, 'cmp) t -> ('a, 'cmp) t val symmetric_diff : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> ('a, 'comp) t -> ('a, 'a) Either.t Sequence.t val compare_direct : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> ('a, 'cmp) t -> int val equal : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> ('a, 'cmp) t -> bool val subset : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> ('a, 'cmp) t -> bool val fold_until : ('a, _) t -> init:'accum -> f:('accum -> 'a -> [ `Continue of 'accum | `Stop of 'accum ]) -> 'accum val fold_right : ('a, _) t -> init:'accum -> f:('a -> 'accum -> 'accum) -> 'accum val iter2 : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> ('a, 'cmp) t -> f:([ `Left of 'a | `Right of 'a | `Both of 'a * 'a ] -> unit) -> unit val filter : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> f:('a -> bool) -> ('a, 'cmp) t val partition_tf : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> f:('a -> bool) -> ('a, 'cmp) t * ('a, 'cmp) t val elements : ('a, _) t -> 'a list val min_elt : ('a, _) t -> 'a option val min_elt_exn : ('a, _) t -> 'a val max_elt : ('a, _) t -> 'a option val max_elt_exn : ('a, _) t -> 'a val choose : ('a, _) t -> 'a option val choose_exn : ('a, _) t -> 'a val split : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> 'a -> ('a, 'cmp) t * 'a option * ('a, 'cmp) t val group_by : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> equiv:('a -> 'a -> bool) -> ('a, 'cmp) t list val find_exn : ('a, _) t -> f:('a -> bool) -> 'a val find_index : ('a, _) t -> int -> 'a option val remove_index : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> int -> ('a, 'cmp) t val to_tree : ('a, 'cmp) t -> ('a, 'cmp) tree val to_sequence : comparator:('a, 'cmp) Comparator.t -> ?order:[ `Increasing | `Decreasing ] -> ?greater_or_equal_to:'a -> ?less_or_equal_to:'a -> ('a, 'cmp) t -> 'a Sequence.t val to_map : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t -> f:('a -> 'b) -> ('a, 'b, 'cmp) Map.t end (** Consistency checks (same as in [Container]). *) module Check_accessors (T : T2) (Tree : T2) (Elt : T1) (Cmp : T1) (Options : T3) (M : Accessors_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Options.t with type ('a, 'b) t := ('a, 'b) T.t with type ('a, 'b) tree := ('a, 'b) Tree.t with type 'a elt := 'a Elt.t with type 'cmp cmp := 'cmp Cmp.t) = struct end module Check_accessors0 (M : Accessors0) = Check_accessors (struct type ('a, 'b) t = M.t end) (struct type ('a, 'b) t = M.tree end) (struct type 'a t = M.elt end) (struct type 'a t = M.comparator_witness end) (Without_comparator) (M) module Check_accessors1 (M : Accessors1) = Check_accessors (struct type ('a, 'b) t = 'a M.t end) (struct type ('a, 'b) t = 'a M.tree end) (struct type 'a t = 'a end) (struct type 'a t = M.comparator_witness end) (Without_comparator) (M) module Check_accessors2 (M : Accessors2) = Check_accessors (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type ('a, 'b) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type 'a t = 'a end) (Without_comparator) (M) module Check_accessors2_with_comparator (M : Accessors2_with_comparator) = Check_accessors (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type ('a, 'b) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type 'a t = 'a end) (With_comparator) (M) module type Creators_generic = sig type ('a, 'cmp) t type ('a, 'cmp) set type ('a, 'cmp) tree type 'a elt type ('a, 'cmp, 'z) options type 'cmp cmp val empty : ('a, 'cmp, ('a, 'cmp) t) options val singleton : ('a, 'cmp, 'a elt -> ('a, 'cmp) t) options val union_list : ('a, 'cmp, ('a, 'cmp) t list -> ('a, 'cmp) t ) options val of_list : ('a, 'cmp, 'a elt list -> ('a, 'cmp) t) options val of_array : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t) options val of_sorted_array : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t Or_error.t) options val of_sorted_array_unchecked : ('a, 'cmp, 'a elt array -> ('a, 'cmp) t) options val stable_dedup_list : ('a, _, 'a elt list -> 'a elt list) options (** The types of [map] and [filter_map] are subtle. The input set, [('a, _) set], reflects the fact that these functions take a set of *any* type, with any comparator, while the output set, [('b, 'cmp) t], reflects that the output set has the particular ['cmp] of the creation function. The comparator can come in one of three ways, depending on which set module is used - [Set.map] -- comparator comes as an argument - [Set.Poly.map] -- comparator is polymorphic comparison - [Foo.Set.map] -- comparator is [Foo.comparator] *) val map : ('b, 'cmp, ('a, _) set -> f:('a -> 'b elt ) -> ('b, 'cmp) t ) options val filter_map : ('b, 'cmp, ('a, _) set -> f:('a -> 'b elt option) -> ('b, 'cmp) t ) options val of_tree : ('a, 'cmp, ('a elt, 'cmp) tree -> ('a, 'cmp) t ) options (** never requires a comparator because it can get one from the input [Map.t] *) val of_map_keys : ('a elt, _, 'cmp cmp) Map.t -> ('a, 'cmp) t end module type Creators0 = sig type ('a, 'cmp) set type t type tree type elt type comparator_witness val empty : t val singleton : elt -> t val union_list : t list -> t val of_list : elt list -> t val of_array : elt array -> t val of_sorted_array : elt array -> t Or_error.t val of_sorted_array_unchecked : elt array -> t val stable_dedup_list : elt list -> elt list val map : ('a, _) set -> f:('a -> elt ) -> t val filter_map : ('a, _) set -> f:('a -> elt option) -> t val of_tree : tree -> t val of_map_keys : (elt, _, comparator_witness) Map.t -> t end module type Creators1 = sig type ('a, 'cmp) set type 'a t type 'a tree type comparator_witness val empty : 'a t val singleton : 'a -> 'a t val union_list : 'a t list -> 'a t val of_list : 'a list -> 'a t val of_array : 'a array -> 'a t val of_sorted_array : 'a array -> 'a t Or_error.t val of_sorted_array_unchecked : 'a array -> 'a t val stable_dedup_list : 'a list -> 'a list val map : ('a, _) set -> f:('a -> 'b ) -> 'b t val filter_map : ('a, _) set -> f:('a -> 'b option) -> 'b t val of_tree : 'a tree -> 'a t val of_map_keys : ('a, _, comparator_witness) Map.t -> 'a t end module type Creators2 = sig type ('a, 'cmp) set type ('a, 'cmp) t type ('a, 'cmp) tree val empty : ('a, 'cmp) t val singleton : 'a -> ('a, 'cmp) t val union_list : ('a, 'cmp) t list -> ('a, 'cmp) t val of_list : 'a list -> ('a, 'cmp) t val of_array : 'a array -> ('a, 'cmp) t val of_sorted_array : 'a array -> ('a, 'cmp) t Or_error.t val of_sorted_array_unchecked : 'a array -> ('a, 'cmp) t val stable_dedup_list : 'a list -> 'a list val map : ('a, _) set -> f:('a -> 'b ) -> ('b, 'cmp) t val filter_map : ('a, _) set -> f:('a -> 'b option) -> ('b, 'cmp) t val of_tree : ('a, 'cmp) tree -> ('a, 'cmp) t val of_map_keys : ('a, _, 'cmp) Map.t -> ('a, 'cmp) t end module type Creators2_with_comparator = sig type ('a, 'cmp) set type ('a, 'cmp) t type ('a, 'cmp) tree val empty : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t val singleton : comparator:('a, 'cmp) Comparator.t -> 'a -> ('a, 'cmp) t val union_list : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) t list -> ('a, 'cmp) t val of_list : comparator:('a, 'cmp) Comparator.t -> 'a list -> ('a, 'cmp) t val of_array : comparator:('a, 'cmp) Comparator.t -> 'a array -> ('a, 'cmp) t val of_sorted_array : comparator:('a, 'cmp) Comparator.t -> 'a array -> ('a, 'cmp) t Or_error.t val of_sorted_array_unchecked : comparator:('a, 'cmp) Comparator.t -> 'a array -> ('a, 'cmp) t val stable_dedup_list : comparator:('a, 'cmp) Comparator.t -> 'a list -> 'a list val map : comparator:('b, 'cmp) Comparator.t -> ('a, _) set -> f:('a -> 'b ) -> ('b, 'cmp) t val filter_map : comparator:('b, 'cmp) Comparator.t -> ('a, _) set -> f:('a -> 'b option) -> ('b, 'cmp) t val of_tree : comparator:('a, 'cmp) Comparator.t -> ('a, 'cmp) tree -> ('a, 'cmp) t val of_map_keys : ('a, _, 'cmp) Map.t -> ('a, 'cmp) t end module Check_creators (T : T2) (Tree : T2) (Elt : T1) (Cmp : T1) (Options : T3) (M : Creators_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) Options.t with type ('a, 'b) t := ('a, 'b) T.t with type ('a, 'b) tree := ('a, 'b) Tree.t with type 'a elt := 'a Elt.t with type 'cmp cmp := 'cmp Cmp.t) = struct end module Check_creators0 (M : Creators0) = Check_creators (struct type ('a, 'b) t = M.t end) (struct type ('a, 'b) t = M.tree end) (struct type 'a t = M.elt end) (struct type 'cmp t = M.comparator_witness end) (Without_comparator) (M) module Check_creators1 (M : Creators1) = Check_creators (struct type ('a, 'b) t = 'a M.t end) (struct type ('a, 'b) t = 'a M.tree end) (struct type 'a t = 'a end) (struct type 'cmp t = M.comparator_witness end) (Without_comparator) (M) module Check_creators2 (M : Creators2) = Check_creators (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type ('a, 'b) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type 'cmp t = 'cmp end) (Without_comparator) (M) module Check_creators2_with_comparator (M : Creators2_with_comparator) = Check_creators (struct type ('a, 'b) t = ('a, 'b) M.t end) (struct type ('a, 'b) t = ('a, 'b) M.tree end) (struct type 'a t = 'a end) (struct type 'cmp t = 'cmp end) (With_comparator) (M) module type Creators_and_accessors_generic = sig include Accessors_generic include Creators_generic with type ('a, 'b, 'c) options := ('a, 'b, 'c) options with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a elt with type 'cmp cmp := 'cmp cmp end module type Creators_and_accessors0 = sig include Accessors0 include Creators0 with type t := t with type tree := tree with type elt := elt with type comparator_witness := comparator_witness end module type Creators_and_accessors1 = sig include Accessors1 include Creators1 with type 'a t := 'a t with type 'a tree := 'a tree with type comparator_witness := comparator_witness end module type Creators_and_accessors2 = sig include Accessors2 include Creators2 with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree end module type Creators_and_accessors2_with_comparator = sig include Accessors2_with_comparator include Creators2_with_comparator with type ('a, 'b) t := ('a, 'b) t with type ('a, 'b) tree := ('a, 'b) tree end module type S0 = sig type ('a, 'cmp) set type ('a, 'cmp) tree module Elt : sig type t with sexp include Comparator.S with type t := t end module Tree : sig type t = (Elt.t, Elt.comparator_witness) tree with compare, sexp include Creators_and_accessors0 with type ('a, 'b) set := ('a, 'b) tree with type t := t with type tree := t with type elt := Elt.t with type comparator_witness := Elt.comparator_witness end type t = (Elt.t, Elt.comparator_witness) set with compare, sexp include Creators_and_accessors0 with type ('a, 'b) set := ('a, 'b) set with type t := t with type tree := Tree.t with type elt := Elt.t with type comparator_witness := Elt.comparator_witness end module type S0_binable = sig include S0 include Binable.S with type t := t end core_kernel-113.00.00/src/core_set_unit_tests.ml000066400000000000000000000432511256461164500215300ustar00rootroot00000000000000module Caml_set = Set open Std open Core_set_intf module Unit_tests (Elt : sig type 'a t with sexp val of_int : int -> int t val to_int : int t -> int end) (Set : sig type ('a, 'b) t_ type ('a, 'b) set type ('a, 'b) tree type ('a, 'b, 'c) create_options include Creators_generic with type ('a, 'b) t := ('a, 'b) t_ with type ('a, 'b) set := ('a, 'b) set with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a Elt.t with type ('a, 'b, 'c) options := ('a, 'b, 'c) create_options val simplify_creator : (int, Int.comparator_witness, 'c) create_options -> 'c type ('a, 'b, 'c) access_options include Accessors_generic with type ('a, 'b) t := ('a, 'b) t_ with type ('a, 'b) tree := ('a, 'b) tree with type 'a elt := 'a Elt.t with type ('a, 'b, 'c) options := ('a, 'b, 'c) access_options with type 'cmp cmp := 'cmp cmp val simplify_accessor : (int, Int.comparator_witness, 'c) access_options -> 'c val kind : [ `Set | `Tree ] end) : Creators_and_accessors_generic = struct module Set = struct include Set let add = simplify_accessor add let remove = simplify_accessor remove let mem = simplify_accessor mem (* let filter = simplify_accessor filter *) (* let compare_direct = simplify_accessor compare_direct *) let equal = simplify_accessor equal let inter = simplify_accessor inter let union = simplify_accessor union let subset = simplify_accessor subset let iter2 = simplify_accessor iter2 let invariants = simplify_accessor invariants let to_map = simplify_accessor to_map let to_list = to_list let to_array = to_array let to_sequence ?order ?greater_or_equal_to ?less_or_equal_to x = simplify_accessor to_sequence ?order ?greater_or_equal_to ?less_or_equal_to x let empty () = simplify_creator empty let singleton = simplify_creator singleton let of_list = simplify_creator of_list let of_sorted_array = simplify_creator of_sorted_array let of_sorted_array_unchecked = simplify_creator of_sorted_array_unchecked (* let of_tree = simplify_creator of_tree *) let symmetric_diff = simplify_accessor symmetric_diff let split = simplify_accessor split let diff = simplify_accessor diff let sexp_of_t_ t = <:sexp_of< int Elt.t list >> (to_list t) end type ('a, 'b) t = Unit_test_follows type ('a, 'b) tree = ('a, 'b) t type ('a, 'b) set = ('a, 'b) t type 'a elt type ('a, 'b, 'c) options = ('a, 'b, 'c) Without_comparator.t type 'a cmp module Elt = struct open Elt let of_int = of_int let to_int = to_int let gen = let open Quickcheck_generator in int >>| of_int module T = struct type t = int Elt.t with sexp let compare t t' = Pervasives.compare (to_int t) (to_int t') let equal t t' = compare t t' = 0 end include T let samples = List.dedup ~compare (List.init 10 ~f:(fun i -> of_int (i + 1))) let absent = of_int 0 let present = of_int 1 let () = assert(List.mem ~equal samples present) let () = assert(not (List.mem ~equal samples absent)) end let set_empty = Set.empty () let set_nonempty = Set.of_list Elt.samples let gen_set = let open Quickcheck_generator in list Elt.gen >>| Set.of_list let add _ = assert false let of_list _ = assert false let mem _ = assert false TEST = List.for_all Elt.samples ~f:(fun e -> Set.mem set_nonempty e) let is_empty _ = assert false TEST = Set.is_empty set_empty TEST = not (Set.is_empty set_nonempty) TEST = let set' = List.fold Elt.samples ~init:(Set.empty ()) ~f:Set.add in Set.equal set_nonempty set' ;; let inter _ = assert false TEST = Set.is_empty (Set.inter set_empty set_nonempty) TEST = Set.is_empty (Set.inter set_nonempty set_empty) TEST = let single = Set.singleton Elt.absent in Set.equal single (Set.inter single (Set.add set_nonempty Elt.absent)) ;; TEST = Set.equal set_nonempty (Set.inter set_nonempty set_nonempty) let subset _ = assert false TEST = Set.subset set_empty set_nonempty TEST = not (Set.subset set_nonempty set_empty) TEST = Set.subset set_nonempty set_nonempty TEST = Set.subset set_empty set_empty TEST = not (Set.subset set_nonempty (Set.singleton Elt.present)) let to_list _ = assert false TEST = let elts = Set.to_list set_nonempty in List.for_all elts ~f:(fun elt -> Set.mem set_nonempty elt) ;; let rec is_list_ordered_ascending xs = match xs with | [] | [_] -> true | a :: b :: xs' -> Elt.compare a b < 0 && is_list_ordered_ascending (b :: xs') ;; TEST = is_list_ordered_ascending (Set.to_list set_nonempty) ;; let to_array _ = assert false TEST = let a = Set.to_array set_nonempty in List.equal (Array.to_list a) (Set.to_list set_nonempty) ~equal:Elt.equal ;; let to_sequence ?order:_ ?greater_or_equal_to:_ ?less_or_equal_to:_ _ : _ Sequence.t = assert false TEST_MODULE "to_sequence" = struct let (<=>) observed expected = <:test_eq< Elt.t list >> (Sequence.to_list observed) expected ;; let m = set_nonempty (* Calibration: make sure [m] contains elements less than 4, greater than 8, and between these two. Otherwise the tests aren't testing what we want. *) TEST = let l = Set.to_list m in List.exists l ~f:(fun x -> x < Elt.of_int 4) && List.exists l ~f:(fun x -> x >= Elt.of_int 4 && x <= Elt.of_int 8) && List.exists l ~f:(fun x -> x > Elt.of_int 8) ;; TEST_UNIT = Set.to_sequence ~order:`Increasing m <=> Set.to_list m TEST_UNIT = Set.to_sequence ~order:`Decreasing m <=> List.rev (Set.to_list m) TEST_UNIT = Set.to_sequence ~order:`Increasing ~greater_or_equal_to:(Elt.of_int 4) m <=> List.filter ~f:(fun x -> x >= Elt.of_int 4) (Set.to_list m) TEST_UNIT = Set.to_sequence m ~order:`Increasing ~greater_or_equal_to:(Elt.of_int 4) ~less_or_equal_to:(Elt.of_int 8) <=> List.filter ~f:(fun x -> x >= Elt.of_int 4 && x <= Elt.of_int 8) (Set.to_list m) TEST_UNIT = Set.to_sequence ~order:`Decreasing ~less_or_equal_to:(Elt.of_int 4) m <=> List.filter ~f:(fun x -> x <= Elt.of_int 4) (List.rev (Set.to_list m)) TEST_UNIT = Set.to_sequence m ~order:`Decreasing ~less_or_equal_to:(Elt.of_int 8) ~greater_or_equal_to:(Elt.of_int 4) <=> List.filter ~f:(fun x -> x <= Elt.of_int 8 && x >= Elt.of_int 4) (List.rev (Set.to_list m)) TEST_UNIT = Set.to_sequence ~order:`Increasing (Set.empty ()) <=> [] TEST_UNIT = Set.to_sequence ~order:`Decreasing (Set.empty ()) <=> [] TEST_UNIT = Set.to_sequence ~order:`Increasing ~greater_or_equal_to:(Elt.of_int 11) m <=> [] TEST_UNIT = Set.to_sequence ~order:`Decreasing ~less_or_equal_to:(Elt.of_int ~-1) m <=> [] end let of_sorted_array _ = assert false let of_sorted_array_unchecked _ = assert false TEST = Set.of_sorted_array [||] |! Result.is_ok TEST = Set.of_sorted_array [|Elt.of_int 0|] |! Result.is_ok TEST = Set.of_sorted_array [|Elt.of_int 0; Elt.of_int 0|] |! Result.is_error TEST = Set.of_sorted_array [|Elt.of_int 1 ; Elt.of_int 0 ; Elt.of_int 1|] |! Result.is_error TEST = let list = List.init 100 ~f:Elt.of_int in let array = Array.of_list list in let rev_array = Array.of_list (List.rev list) in Set.equal (Set.of_list list) (Set.of_sorted_array_unchecked array) && Set.equal (Set.of_list list) (Set.of_sorted_array_unchecked rev_array) ;; let invariants _ = assert false TEST_UNIT = for n = 0 to 100 do let list = List.init n ~f:Elt.of_int in assert (List.permute list |! Set.of_list |! Set.invariants); assert (Array.of_list list |! Set.of_sorted_array_unchecked |! Set.invariants); assert (List.rev list |! Array.of_list |! Set.of_sorted_array_unchecked |! Set.invariants); done ;; let iter2 _ = assert false TEST_UNIT = let test l1 l2 expected = let result = ref [] in let set_of_list l = Set.of_list (List.map l ~f:Elt.of_int) in Set.iter2 (set_of_list l1) (set_of_list l2) ~f:(fun a -> result := a :: !result); let result = List.rev_map !result ~f:(function | `Left a -> `Left (Elt.to_int a) | `Right a -> `Right (Elt.to_int a) | `Both (a, b) -> `Both (Elt.to_int a, Elt.to_int b) ) in assert (result = expected) in test [] [] []; test [0] [] [`Left 0]; test [] [0] [`Right 0]; test [0; 1; 3; 4] [3; 4; 5; 6] [`Left 0; `Left 1; `Both (3, 3); `Both (4, 4); `Right 5; `Right 6 ]; ;; (* Ensure polymorphic equality raises for sets. *) TEST_UNIT = match Set.kind with | `Tree -> () | `Set -> let ts = [ Set.empty (); Set.of_list [ Elt.of_int 13 ] ] in List.iter ts ~f:(fun t1 -> List.iter ts ~f:(fun t2 -> assert (Result.is_error (Result.try_with (fun () -> Poly.equal t1 t2))))); ;; let to_map _ = assert false TEST_UNIT = assert (Map.is_empty (Set.to_map set_empty ~f:Elt.to_int)) TEST_UNIT = let s = set_nonempty in let m = Set.to_map s ~f:Elt.to_int in assert (Set.length s = Map.length m); Map.iter m ~f:(fun ~key ~data -> assert (Elt.to_int key = data)); assert (Set.to_list s = Map.keys m); ;; let of_map_keys _ = assert false TEST_UNIT = assert (Set.is_empty (Set.of_map_keys (Set.to_map set_empty ~f:Elt.to_int))) TEST_UNIT = assert (Set.equal (Set.of_map_keys (Set.to_map set_nonempty ~f:Elt.to_int)) set_nonempty) let symmetric_diff _ = assert false TEST_UNIT "symmetric diff quick" = let symmetric_diff_set s1 s2 = Set.symmetric_diff s1 s2 |> Sequence.to_list |> List.map ~f:(function | First elt | Second elt -> elt) |> Set.of_list in (* Textbook definition of symmetric difference: *) let symmetric_diff_spec s1 s2 = Set.diff (Set.union s1 s2) (Set.inter s1 s2) in Quickcheck.test ~seed:(`Deterministic "core set symmetric diff") (Quickcheck_generator.tuple2 gen_set gen_set) ~sexp_of:<:sexp_of< Set.t_ * Set.t_ >> ~f:(fun (s1, s2) -> let expect = symmetric_diff_spec s1 s2 in let actual = symmetric_diff_set s1 s2 in assert (Set.equal actual expect)) TEST = let m1 = set_nonempty in Sequence.to_list (Set.symmetric_diff m1 m1) = [] ;; TEST = let elt = Elt.of_int 7 in let m1 = Set.empty () in let m1 = Set.add m1 (Elt.of_int 1) in let m2 = Set.add m1 elt in Sequence.to_list (Set.symmetric_diff m1 m2) = [Second elt] ;; TEST = let m1 = set_nonempty in let m2 = List.fold (Set.to_list m1) ~init:(Set.empty ()) ~f:(fun m k -> Set.add m k) in Sequence.to_list (Set.symmetric_diff m1 m2) = [] ;; TEST = let elt = Elt.of_int 20 in let m1 = set_nonempty in let m2 = Set.add m1 elt in Sequence.to_list (Set.symmetric_diff m1 m2) = [Second elt] ;; TEST = let elt = Elt.of_int 5 in let m1 = set_nonempty in let m2 = Set.remove m1 elt in Sequence.to_list (Set.symmetric_diff m1 m2) = [First elt] ;; let set_of_int_list l = Set.of_list (List.map ~f:Elt.of_int l) TEST = let map1 = Set.empty () in let map2 = set_of_int_list [ 1 ; 2 ; 3 ; 4 ; 5 ] in let diff = Set.symmetric_diff map1 map2 in Sequence.length diff = 5 ;; TEST = let map1 = set_of_int_list [ 1 ; 2 ; 3 ; 4 ; 5 ] in let map2 = Set.empty () in let diff = Set.symmetric_diff map1 map2 in Sequence.length diff = 5 ;; TEST = let map1 = set_of_int_list [ 1 ; 2 ] in let map2 = List.fold [ 3 ; 4 ; 5 ] ~init:map1 ~f:(fun acc elt -> Set.add acc (Elt.of_int elt)) in let diff = Set.symmetric_diff map1 map2 in Sequence.length diff = 3 ;; TEST = let map2 = set_of_int_list [ 1; 2 ] in let map1 = List.fold [ 3; 4; 5 ] ~init:map2 ~f:(fun acc elt -> Set.add acc (Elt.of_int elt)) in let diff = Set.symmetric_diff map1 map2 in Sequence.length diff = 3 ;; let split _ = assert false module Simple_int_set = struct type t = int list with compare, sexp let init i = List.init i ~f:Fn.id let split t i = let l = List.filter t ~f:(Int.(>) i) in let r = List.filter t ~f:(Int.(<) i) in let x = if List.mem t i ~equal:(Int.(=)) then Some (Elt.of_int i) else None in (l, x, r) ;; let to_set = set_of_int_list end TEST_UNIT = let n = 16 in let t = set_of_int_list (List.init n ~f:Fn.id) in let t' = Simple_int_set.init n in let check i = let l, x, r = Set.split t (Elt.of_int i) in let l', x', r' = Simple_int_set.split t' i in assert (Set.equal l (Simple_int_set.to_set l')); <:test_eq< Elt.t option >> x x'; assert (Set.equal r (Simple_int_set.to_set r')); in for i = 0 to n - 1 do check i done; ;; let to_tree _ = assert false let remove_index _ = assert false let find_index _ = assert false let find_exn _ = assert false let group_by _ = assert false let choose_exn _ = assert false let choose _ = assert false let max_elt_exn _ = assert false let max_elt _ = assert false let min_elt_exn _ = assert false let min_elt _ = assert false let elements _ = assert false let partition_tf _ = assert false let filter _ = assert false let fold_right _ = assert false let fold_until _ = assert false let equal _ = assert false let compare_direct _ = assert false let diff _ = assert false let union _ = assert false let remove _ = assert false let find_map _ = assert false let find _ = assert false let count _ = assert false let sum _ = assert false let for_all _ = assert false let exists _ = assert false let fold _ = assert false let iter _ = assert false let length _ = assert false let of_tree _ = assert false let filter_map _ = assert false let map _ = assert false let stable_dedup_list _ = assert false let of_array _ = assert false let union_list _ = assert false let singleton _ = assert false let empty = Unit_test_follows end module Elt_int = struct type 'a t = int with sexp let of_int = Fn.id let to_int = Fn.id end module Elt_poly = struct type 'a t = 'a with sexp let of_int = Fn.id let to_int = Fn.id end module Create_options_with_comparator = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) With_comparator.t let simplify_creator f = f ~comparator:Core_int.comparator end module Create_options_without_comparator = struct type ('a, 'b, 'c) create_options = ('a, 'b, 'c) Without_comparator.t let simplify_creator = Fn.id end module Access_options_without_comparator = struct type ('a, 'b, 'c) access_options = ('a, 'b, 'c) Without_comparator.t let simplify_accessor = Fn.id end module Access_options_with_comparator = struct type ('a, 'b, 'c) access_options = ('a, 'b, 'c) With_comparator.t let simplify_accessor f = f ~comparator:Core_int.comparator end TEST_MODULE "Set" = Unit_tests (Elt_poly) (struct include Set type ('a, 'b) t_ = ('a, 'b) t type ('a, 'b) set = ('a, 'b) t type ('a, 'b) tree = ('a, 'b) Tree.t type 'a cmp = 'a include Create_options_with_comparator include Access_options_without_comparator let kind = `Set end) TEST_MODULE "Set.Poly" = Unit_tests (Elt_poly) (struct include Set.Poly type ('a, 'b) set = ('a, 'b) Set.t type ('a, 'b) t_ = 'a t type ('a, 'b) tree = 'a Tree.t type 'a cmp = Comparator.Poly.comparator_witness include Create_options_without_comparator include Access_options_without_comparator let kind = `Set end) TEST_MODULE "Int.Set" = Unit_tests (Elt_int) (struct include Int.Set type ('a, 'b) set = ('a, 'b) Set.t type ('a, 'b) t_ = t type ('a, 'b) tree = Tree.t type 'a cmp = Int.comparator_witness include Create_options_without_comparator include Access_options_without_comparator let kind = `Set end) TEST_MODULE "Set.Tree" = Unit_tests (Elt_poly) (struct include Set.Tree type ('a, 'b) set = ('a, 'b) Set.Tree.t type ('a, 'b) t_ = ('a, 'b) t type ('a, 'b) tree = ('a, 'b) t type 'a cmp = 'a include Create_options_with_comparator include Access_options_with_comparator let kind = `Tree end) TEST_MODULE "Set.Poly.Tree" = Unit_tests (Elt_poly) (struct include Set.Poly.Tree type ('a, 'b) set = 'a Set.Poly.Tree.t type ('a, 'b) t_ = 'a t type ('a, 'b) tree = 'a t type 'a cmp = Comparator.Poly.comparator_witness include Create_options_without_comparator include Access_options_without_comparator let kind = `Tree end) TEST_MODULE "Int.Set.Tree" = Unit_tests (Elt_int) (struct include Int.Set.Tree type ('a, 'b) set = ('a, 'b) Set.Tree.t type ('a, 'b) t_ = t type ('a, 'b) tree = t type 'a cmp = Int.comparator_witness include Create_options_without_comparator include Access_options_without_comparator let kind = `Tree end) core_kernel-113.00.00/src/core_set_unit_tests.mli000066400000000000000000000000561256461164500216750ustar00rootroot00000000000000(* Unit test interface intentionally blank *) core_kernel-113.00.00/src/core_sexp.ml000066400000000000000000000107351256461164500174340ustar00rootroot00000000000000module Sexp = Sexplib.Sexp open Sexplib.Std open Bin_prot.Std include Sexp exception Of_sexp_error = Sexplib.Conv.Of_sexp_error module O = struct type sexp = Sexp.t = Atom of string | List of t list end module T : sig include Interfaces.Sexpable with type t := Sexp.t include Interfaces.Binable with type t := Sexp.t val compare : t -> t -> int end = struct type t = Sexp.t = Atom of string | List of t list with bin_io, compare let sexp_of_t t = t let t_of_sexp t = t end include T module Sexp_option = struct type 'a t = 'a option with bin_io, compare end module Sexp_list = struct type 'a t = 'a list with bin_io, compare end module Sexp_array = struct type 'a t = 'a array with bin_io, compare end module Sexp_opaque = struct type 'a t = 'a with bin_io, compare end module Sexp_maybe = struct type sexp = t with bin_io, compare (* avoid recursive type *) (* to satisfy pa_compare *) module Error = struct include Error include Comparable.Poly (Error) end type 'a t = ('a, sexp * Error.t) Result.t with bin_io, compare let sexp_of_t sexp_of_a t = match t with | Result.Ok a -> sexp_of_a a | Result.Error (sexp, err) -> Sexp.List [ Sexp.Atom "sexp_parse_error"; sexp; Error.sexp_of_t err; ] let t_of_sexp a_of_sexp sexp = match sexp with | Sexp.List [ Sexp.Atom "sexp_parse_error"; sexp; _ ] | sexp -> try Result.Ok (a_of_sexp sexp) with exn -> Result.Error (sexp, Error.of_exn exn) end module With_text = struct open Result.Export type 'a t = { value: 'a ; text: string } with bin_io let sexp_of_t _ t = Sexp.Atom t.text let of_text value_of_sexp ?(filename="") text = match Or_error.try_with (fun () -> Sexp.of_string_conv (Core_string.strip text) value_of_sexp) with | Ok (`Result value) -> Ok { value; text } | Error _ as err -> err | Ok (`Error (exn, annotated)) -> Error (Error.of_exn (Sexp.Annotated.get_conv_exn annotated ~file:filename ~exc:exn)) let t_of_sexp a_of_sexp sexp = match sexp with | List _ -> Sexplib.Conv.of_sexp_error "With_text.t should be stored as an atom, but instead a list was found." sexp | Atom text -> of_text a_of_sexp text |> Or_error.ok_exn let text t = t.text let value t = t.value let of_value sexp_of_value value = let text = sexp_of_value value |> Sexp.to_string_hum in { value; text } TEST_MODULE = struct let sexp_of_il = sexp_of_list sexp_of_int let il_of_sexp = list_of_sexp int_of_sexp let il_of_text text = Or_error.ok_exn (of_text il_of_sexp text) let il_of_value il = of_value sexp_of_il il let t = il_of_value [3;4] TEST = t.text = "(3 4)" let t' = il_of_text (text t) TEST = t'.value = [3;4] TEST = sexp_of_t sexp_of_il t = Atom "(3 4)" TEST = (t_of_sexp il_of_sexp (Atom "(3 4)")).value = [3;4] TEST = [8;9] = (il_of_text ";this is a comment\n (8; foo\n 9) \n ").value let check_error f input ~expected = let normalize str = try Sexp.to_string (Sexp.of_string str) with _ -> str in let expected = normalize expected in try ignore (f input); failwith (Printf.sprintf "%s expected to cause an exception, \ but got converted successfully." input) with e -> let error = normalize (Printexc.to_string e) in if error <> expected then failwith (Printf.sprintf "%s generated error %s, expected %s" input error expected) let expected = "(Sexplib.Conv.Of_sexp_error( Sexplib.Sexp.Annotated.Conv_exn :1:5(Failure\"int_of_sexp: (Failure int_of_string)\"))bla)" TEST_UNIT = check_error il_of_text "(1 2 bla)" ~expected TEST_UNIT = check_error (fun s -> t_of_sexp il_of_sexp (Sexp.of_string s)) "\"(1 2 bla)\"" ~expected end end let of_int_style = Int_conversions.sexp_of_int_style type 'a no_raise = 'a with bin_io, sexp let sexp_of_no_raise sexp_of_a a = try sexp_of_a a with exn -> try List [ Atom "failure building sexp"; sexp_of_exn exn ] with _ -> Atom "could not build sexp for exn raised when building sexp for value" ;; include Comparable.Make (struct type t = Sexp.t include T end) let of_sexp_allow_extra_fields of_sexp sexp = let r = Sexplib.Conv.record_check_extra_fields in let prev = !r in Exn.protect ~finally:(fun () -> r := prev) ~f:(fun () -> r := false; of_sexp sexp) core_kernel-113.00.00/src/core_sexp.mli000066400000000000000000000077761256461164500176200ustar00rootroot00000000000000open Interfaces open Sexplib (** Code for managing s-expressions *) type t = Sexp.t = Atom of string | List of t list with bin_io, sexp module O : sig type sexp = Sexp.t = Atom of string | List of t list end include Comparable with type t := t include Stringable with type t := t include Sexp_intf.S with type t := t exception Of_sexp_error of exn * t val of_int_style : [ `Underscores | `No_underscores ] ref (** [no_raise] is the identity, but by using ['a no_raise] in a sexpable type, the resulting use [sexp_of_no_raise] protects the conversion of ['a] to a sexp so that if it fails, one gets a sexp with an error message about the failure, rather than an exception being raised. WARNING: The resulting [no_raise_of_sexp] can still raise. *) type 'a no_raise = 'a with bin_io, sexp (** Please refer to the Sexplib documentation in base/sexplib/doc to learn more about sexp_option, sexp_list, and sexp_array generators. *) (** The purpose of these modules is to allow bin_io to work with these special sexp types. The more direct method of adding "with bin_io" at the point of the initial declaration of the types is not possible because sexplib does not (should not) depend on bin_io. *) module Sexp_option : sig type 'a t = 'a option with bin_io, compare end module Sexp_list : sig type 'a t = 'a list with bin_io, compare end module Sexp_array : sig type 'a t = 'a array with bin_io, compare end module Sexp_opaque : sig type 'a t = 'a with bin_io, compare end (** If [sexp_of_t fails], it returns [Error] rather than raising. You can convert values of this type to and from sexp in processes that can or cannot parse the underlying sexp in any combination and still recover the original value. Also, the [Error] case contains a human-readable description of the error. A common use case is to parse most of a sexp even when some small part fails to parse, e.g.: {[ type query = | Start of Initial_config.t Sexp_maybe.t | Stop of Reason_to_stop.t Sexp_maybe.t with sexp ]} If [Reason_to_stop.t_of_sexp] fails, you can still tell it was a [Stop] query. *) module Sexp_maybe : sig type 'a t = ('a, Sexp.t * Error.t) Result.t with bin_io, compare, sexp end (** A [With_text.t] is a value paired with the full textual representation of its sexp. This is useful for dealing with the case where you want to keep track of a value along with the format of the s-expression it was generated from, which allows you to maintain formatting details, comments, etc. The s-expression representation of a [With_text.t] is the raw text, stored as an atom. The bin_io representation contains both the bin_io of the underlying value and the bin_io'd version of the raw text. This is similar to but simpler than the [With_layout] module included above (via [Sexp_intf.S]), which gives you access to a fully parsed version of the s-expression, with attached comments and layout information, to allow you to build layout-preserving s-expression transformations. The invariants of a [x With_text.t] are broken if the [x] value is mutated. *) module With_text : sig type 'a t with sexp, bin_io (** Generates a [t] from the value by creating the text automatically using the provided s-expression converter. *) val of_value : ('a -> Sexp.t) -> 'a -> 'a t (** Creates a [t] from the text, by first converting the text to an s-expression, and then parsing the s-expression with the provided converter. *) val of_text : (Sexp.t -> 'a) -> ?filename:string (** used for error reporting *) -> string -> 'a t Or_error.t val value : 'a t -> 'a val text : 'a t -> string end (** [of_sexp_allow_extra_fields of_sexp sexp] uses [of_sexp] to convert [sexp] to a value, but will not fail if there are any extra fields in a record (even deeply nested records). The implementation uses global state, so it is not thread safe. *) val of_sexp_allow_extra_fields : (Sexp.t -> 'a) -> Sexp.t -> 'a core_kernel-113.00.00/src/core_stack.ml000066400000000000000000000102301256461164500175500ustar00rootroot00000000000000open Std_internal open Fieldslib (* This implementation is similar to [Deque] in that it uses an array of ['a] and a mutable [int] to indicate what in the array is used. We choose to implement [Stack] directly rather than on top of [Deque] for performance reasons. E.g. a simple microbenchmark shows that push/pop is about 20% faster. *) type 'a t = { (* [dummy] is a value that we create via [Obj.magic] and use for empty slots in [elts]. It is intended that [dummy] is never returned to user code. *) dummy : 'a; mutable length : int; mutable elts : 'a array; } with bin_io, fields, sexp_of let sexp_of_t_internal = sexp_of_t let sexp_of_t = `Rebound_later let _ = sexp_of_t let capacity t = Array.length t.elts let invariant invariant_a t : unit = try let check f field = f (Field.get field t) in Fields.iter ~dummy:ignore ~length:(check (fun length -> assert (0 <= length && length <= Array.length t.elts))) ~elts:(check (fun elts -> for i = 0 to t.length - 1 do invariant_a elts.(i); done; (* We maintain the invariant that unused elements equal [t.dummy] to avoid a space leak. *) for i = t.length to Array.length elts - 1 do assert (phys_equal elts.(i) t.dummy) done; )); with exn -> failwiths "Stack.invariant failed" (exn, t) <:sexp_of< exn * _ t_internal >> ;; let create (type a) () : a t = let dummy = (Obj.magic () : a) in { dummy; length = 0; elts = [||]; } ;; let length t = t.length let is_empty t = length t = 0 (* The order in which elements are visited has been chosen so as to be backwards compatible with both [Linked_stack] and [Caml.Stack] *) let fold t ~init ~f = let r = ref init in for i = t.length - 1 downto 0 do r := f !r t.elts.(i) done; !r ;; let iter t ~f = for i = t.length - 1 downto 0 do f t.elts.(i) done; ;; module C = Container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter end) let mem = C.mem let exists = C.exists let for_all = C.for_all let count = C.count let sum = C.sum let find = C.find let find_map = C.find_map let to_list = C.to_list let to_array = C.to_array let min_elt = C.min_elt let max_elt = C.max_elt let of_list (type a) (l : a list) = if List.is_empty l then create () else begin let dummy = (Obj.magic () : a) in let length = List.length l in let elts = Array.create ~len:(2 * length) dummy in let r = ref l in for i = length - 1 downto 0 do match !r with | [] -> assert false | a :: l -> elts.(i) <- a; r := l done; { dummy; length; elts } end ;; let sexp_of_t sexp_of_a t = <:sexp_of< a list >> (to_list t) let t_of_sexp a_of_sexp sexp = of_list (<:of_sexp< a list >> sexp) let resize t size = t.elts <- Array.init size ~f:(fun i -> if i < t.length then t.elts.(i) else t.dummy); ;; let set_capacity t new_capacity = let new_capacity = max new_capacity (length t) in if new_capacity <> capacity t then resize t new_capacity; ;; let push t a = if t.length = Array.length t.elts then resize t (2 * (t.length + 1)); t.elts.(t.length) <- a; t.length <- t.length + 1; ;; let pop_nonempty t = let i = t.length - 1 in let result = t.elts.(i) in t.elts.(i) <- t.dummy; t.length <- i; result ;; let pop_error = Error.of_string "Stack.pop of empty stack" let pop t = if is_empty t then None else Some (pop_nonempty t) ;; let pop_exn t = if is_empty t then Error.raise pop_error else pop_nonempty t ;; let top_nonempty t = t.elts.(t.length - 1) let top_error = Error.of_string "Stack.top of empty stack" let top t = if is_empty t then None else Some (top_nonempty t) ;; let top_exn t = if is_empty t then Error.raise top_error else top_nonempty t; ;; let copy { dummy; length; elts } = { dummy; length; elts = Array.copy elts; } ;; let clear t = if t.length > 0 then begin for i = 0 to t.length - 1 do t.elts.(i) <- t.dummy; done; t.length <- 0; end; ;; let until_empty t f = let rec loop () = if t.length > 0 then (f (pop_nonempty t); loop ()) in loop () ;; core_kernel-113.00.00/src/core_stack.mli000066400000000000000000000010651256461164500177270ustar00rootroot00000000000000(** A stack implemented with an array. See {!Stack_intf} for documentation. The implementation will grow the array as necessary, and will never automatically shrink the array. One can use [set_capacity] to explicitly resize the array. *) include Stack_intf.S (** [capacity t] returns the length of the array backing [t]. *) val capacity : _ t -> int (** [set_capacity t capacity] sets the length of the array backing [t] to [max capacity (length t)]. To shrink as much as possible, do [set_capacity t 0]. *) val set_capacity : _ t -> int -> unit core_kernel-113.00.00/src/core_string.ml000066400000000000000000001454751256461164500177750ustar00rootroot00000000000000module Array = Caml.ArrayLabels module Char = Core_char module String = Caml.StringLabels module List = Core_list open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std open Result.Export open Staged let phys_equal = (==) let invalid_argf = Core_printf.invalid_argf let failwiths = Error.failwiths module T = struct type t = string with sexp, bin_io, typerep let compare = String.compare (* = on two strings avoids calling compare_val, which is what happens with String.compare *) let equal (x : string) y = x = y end include T type elt = char let max_length = Caml.Sys.max_string_length (* Standard functions *) let capitalize = String.capitalize let (^) = (^) let concat ?(sep="") l = String.concat ~sep l let copy = String.copy let escaped = String.escaped let fill = String.fill let index_exn = String.index let index_from_exn = String.index_from let lowercase = String.lowercase let make = String.make let rindex_exn = String.rindex let rindex_from_exn = String.rindex_from let uncapitalize = String.uncapitalize let uppercase = String.uppercase external create : int -> string = "caml_create_string" external get : string -> int -> char = "%string_safe_get" external unsafe_get : string -> int -> char = "%string_unsafe_get" external length : string -> int = "%string_length" external set : string -> int -> char -> unit = "%string_safe_set" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" module Caseless = struct module T = struct type t = string with bin_io, sexp (* This function gives the same result as [compare (lowercase s1) (lowercase s2)]. It is optimised so that it is as fast as that implementation, but uses constant memory instead of O(n). It is still an order of magnitude slower than the inbuilt string comparison, sadly. *) let compare s1 s2 = if phys_equal s1 s2 then 0 else With_return.with_return (fun r -> for i = 0 to min (length s1) (length s2) - 1 do match Char.compare (Char.lowercase (unsafe_get s1 i)) (Char.lowercase (unsafe_get s2 i)) with | 0 -> () | other -> r.return other done; (* the Int module is not available here, and [compare] is string comparison *) Polymorphic_compare.compare (length s1) (length s2)) BENCH_FUN "compare" = let s1 = String.init 1000 ~f:(fun i -> "aBcDeFgHiJkLmNoPqRsTuVwXyZ !?.".[i mod 30]) in let s2 = copy s1 in fun () -> ignore (compare s1 s2) let hash s = let len_s = length s in let rec loop acc i = if i = len_s then acc else loop (Hashtbl.seeded_hash acc (Char.lowercase s.[i])) (i + 1) in loop 0 0 ;; BENCH_FUN "hash" = let s = String.init 1000 ~f:(fun i -> Char.of_int_exn (i mod 256)) in fun () -> ignore (hash s) end include T include Comparable.Make_binable(T) include Hashable.Make_binable(T) end TEST_MODULE "Caseless" = struct (* examples from docs *) TEST = Caseless.equal "OCaml" "ocaml" TEST = Caseless.("apple" < "Banana") TEST = Caseless.("aa" < "aaa") TEST = Caseless.compare "apple" "Banana" <> T.compare "apple" "Banana" TEST = Caseless.equal "XxX" "xXx" TEST = Caseless.("XxX" < "xXxX") TEST = Caseless.("XxXx" > "xXx") TEST = List.is_sorted ~compare:Caseless.compare ["Apples"; "bananas"; "Carrots"] TEST = Core_map.find_exn (Caseless.Map.of_alist_exn [("a", 4); ("b", 5)]) "A" = 4 TEST = Core_set.mem (Caseless.Set.of_list ["hello"; "world"]) "heLLO" TEST = Core_set.length (Caseless.Set.of_list ["a"; "A"]) = 1 TEST = Core_hashtbl.hash "x" <> Core_hashtbl.hash "X" && Caseless.hash "x" = Caseless.hash "X" TEST = Caseless.hash "OCaml" = Caseless.hash "ocaml" TEST = Caseless.hash "aaa" <> Caseless.hash "aaaa" TEST = Caseless.hash "aaa" <> Caseless.hash "aab" TEST = let tbl = Caseless.Table.create () in Core_hashtbl.add_exn tbl ~key:"x" ~data:7; Core_hashtbl.find tbl "X" = Some 7 end include Blit.Make (struct type t = char let equal = (=) let of_bool b = if b then 'a' else 'b' end) (struct type nonrec t = t with sexp_of let create ~len = create len let length = length let get = get let set = set let unsafe_blit = String.unsafe_blit end) ;; let contains ?pos ?len t char = let (pos, len) = Ordered_collection_common.get_pos_len_exn ?pos ?len ~length:(length t) in let last = pos + len in let rec loop i = i < last && (t.[i] = char || loop (i + 1)) in loop pos ;; TEST = contains "" 'a' = false TEST = contains "a" 'a' = true TEST = contains "a" 'b' = false TEST = contains "ab" 'a' = true TEST = contains "ab" 'b' = true TEST = contains "ab" 'c' = false TEST = contains "abcd" 'b' ~pos:1 ~len:0 = false TEST = contains "abcd" 'b' ~pos:1 ~len:1 = true TEST = contains "abcd" 'c' ~pos:1 ~len:2 = true TEST = contains "abcd" 'd' ~pos:1 ~len:2 = false TEST = contains "abcd" 'd' ~pos:1 = true TEST = contains "abcd" 'a' ~pos:1 = false let is_empty t = length t = 0 let index t char = try Some (index_exn t char) with Not_found -> None let rindex t char = try Some (rindex_exn t char) with Not_found -> None let index_from t pos char = try Some (index_from_exn t pos char) with Not_found -> None let rindex_from t pos char = try Some (rindex_from_exn t pos char) with Not_found -> None module Search_pattern = struct type t = string * int array with sexp_of (* Find max number of matched characters at [next_text_char], given the current [matched_chars]. Try to extend the current match, if chars don't match, try to match fewer chars. If chars match then extend the match. *) let kmp_internal_loop ~matched_chars ~next_text_char ~pattern ~kmp_arr = let matched_chars = ref matched_chars in while !matched_chars > 0 && next_text_char <> unsafe_get pattern !matched_chars do matched_chars := Core_array.unsafe_get kmp_arr (!matched_chars - 1) done; if next_text_char = unsafe_get pattern !matched_chars then matched_chars := !matched_chars + 1; !matched_chars ;; (* Classic KMP pre-processing of the pattern: build the int array, which, for each i, contains the length of the longest non-trivial prefix of s which is equal to a suffix ending at s.[i] *) let create pattern = let n = length pattern in let kmp_arr = Core_array.create ~len:n (-1) in if n > 0 then begin Core_array.unsafe_set kmp_arr 0 0; let matched_chars = ref 0 in for i = 1 to n - 1 do matched_chars := kmp_internal_loop ~matched_chars:!matched_chars ~next_text_char:(unsafe_get pattern i) ~pattern ~kmp_arr; Core_array.unsafe_set kmp_arr i !matched_chars done end; (pattern, kmp_arr) ;; TEST_MODULE "Search_pattern.create" = struct let prefix s n = sub s ~pos:0 ~len:n let suffix s n = sub s ~pos:(length s - n) ~len:n let slow_create pattern = (* Compute the longest prefix-suffix array from definition, O(n^3) *) let n = length pattern in let kmp_arr = Core_array.create ~len:n (-1) in for i = 0 to n - 1 do let x = prefix pattern (i + 1) in for j = 0 to i do if prefix x j = suffix x j then kmp_arr.(i) <- j done done; (pattern, kmp_arr) ;; let test_both (s, a) = create s = (s, a) && slow_create s = (s, a) let cmp_both s = create s = slow_create s TEST = test_both ("", [| |]) TEST = test_both ("ababab", [|0; 0; 1; 2; 3; 4|]) TEST = test_both ("abaCabaD", [|0; 0; 1; 0; 1; 2; 3; 0|]) TEST = test_both ("abaCabaDabaCabaCabaDabaCabaEabab", [|0; 0; 1; 0; 1; 2; 3; 0; 1; 2; 3; 4; 5; 6; 7; 4; 5; 6; 7; 8; 9; 10; 11; 12; 13; 14; 15; 0; 1; 2; 3; 2|]) let rec x k = if k < 0 then "" else let b = x (k - 1) in b ^ (make 1 (Caml.Char.unsafe_chr (65 + k))) ^ b ;; TEST = cmp_both (x 10) TEST = cmp_both ((x 5) ^ "E" ^ (x 4) ^ "D" ^ (x 3) ^ "B" ^ (x 2) ^ "C" ^ (x 3)) end (* Classic KMP: use the pre-processed pattern to optimize look-behinds on non-matches. We return int to avoid allocation in [index_exn]. -1 means no match. *) let index_internal ?(pos=0) (pattern, kmp_arr) ~in_:text = if pos < 0 || pos > length text - length pattern then -1 else begin let j = ref pos in let matched_chars = ref 0 in let k = length pattern in let n = length text in while !j < n && !matched_chars < k do let next_text_char = unsafe_get text !j in matched_chars := kmp_internal_loop ~matched_chars:!matched_chars ~next_text_char ~pattern ~kmp_arr; j := !j + 1 done; if !matched_chars = k then !j - k else -1 end ;; let index ?pos t ~in_ = let p = index_internal ?pos t ~in_ in if p < 0 then None else Some p ;; TEST = index (create "") ~in_:"abababac" = Some 0 TEST = index ~pos:(-1) (create "") ~in_:"abababac" = None TEST = index ~pos:1 (create "") ~in_:"abababac" = Some 1 TEST = index ~pos:7 (create "") ~in_:"abababac" = Some 7 TEST = index ~pos:8 (create "") ~in_:"abababac" = Some 8 TEST = index ~pos:9 (create "") ~in_:"abababac" = None TEST = index (create "abababaca") ~in_:"abababac" = None TEST = index (create "abababac") ~in_:"abababac" = Some 0 TEST = index ~pos:0 (create "abababac") ~in_:"abababac" = Some 0 TEST = index (create "abac") ~in_:"abababac" = Some 4 TEST = index ~pos:4 (create "abac") ~in_:"abababac" = Some 4 TEST = index ~pos:5 (create "abac") ~in_:"abababac" = None TEST = index ~pos:5 (create "abac") ~in_:"abababaca" = None TEST = index ~pos:5 (create "baca") ~in_:"abababaca" = Some 5 TEST = index ~pos:(-1) (create "a") ~in_:"abc" = None TEST = index ~pos:2 (create "a") ~in_:"abc" = None TEST = index ~pos:2 (create "c") ~in_:"abc" = Some 2 TEST = index ~pos:3 (create "c") ~in_:"abc" = None let index_exn ?pos t ~in_ = let p = index_internal ?pos t ~in_ in if p >= 0 then p else failwiths "Substring not found" (fst t) sexp_of_string ;; let index_all (pattern, kmp_arr) ~may_overlap ~in_:text = if length pattern = 0 then List.init (1 + length text) ~f:Fn.id else begin let matched_chars = ref 0 in let k = length pattern in let n = length text in let found = ref [] in for j = 0 to n do if !matched_chars = k then begin found := (j - k)::!found; (* we just found a match in the previous iteration *) match may_overlap with | true -> matched_chars := Core_array.unsafe_get kmp_arr (k - 1) | false -> matched_chars := 0 end; if j < n then begin let next_text_char = unsafe_get text j in matched_chars := kmp_internal_loop ~matched_chars:!matched_chars ~next_text_char ~pattern ~kmp_arr end done; Core_list.rev !found end ;; TEST = index_all (create "") ~may_overlap:false ~in_:"abcd" = [0; 1; 2; 3; 4] TEST = index_all (create "") ~may_overlap:true ~in_:"abcd" = [0; 1; 2; 3; 4] TEST = index_all (create "abab") ~may_overlap:false ~in_:"abababab" = [0; 4] TEST = index_all (create "abab") ~may_overlap:true ~in_:"abababab" = [0; 2; 4] TEST = index_all (create "abab") ~may_overlap:false ~in_:"ababababab" = [0; 4] TEST = index_all (create "abab") ~may_overlap:true ~in_:"ababababab" = [0; 2; 4; 6] TEST = index_all (create "aaa") ~may_overlap:false ~in_:"aaaaBaaaaaa" = [0; 5; 8] TEST = index_all (create "aaa") ~may_overlap:true ~in_:"aaaaBaaaaaa" = [0; 1; 5; 6; 7; 8] let replace_first ?pos t ~in_:s ~with_ = match index ?pos t ~in_:s with | None -> s | Some i -> let len_s = length s in let len_t = length (fst t) in let len_with = length with_ in let dst = make (len_s + len_with - len_t) ' ' in blit ~src:s ~src_pos:0 ~dst ~dst_pos:0 ~len:i; blit ~src:with_ ~src_pos:0 ~dst ~dst_pos:i ~len:len_with; blit ~src:s ~src_pos:(i + len_t) ~dst ~dst_pos:(i + len_with) ~len:(len_s - i - len_t); dst ;; TEST = replace_first (create "abab") ~in_:"abababab" ~with_:"" = "abab" TEST = replace_first (create "abab") ~in_:"abacabab" ~with_:"" = "abac" TEST = replace_first (create "abab") ~in_:"ababacab" ~with_:"A" = "Aacab" TEST = replace_first (create "abab") ~in_:"acabababab" ~with_:"A" = "acAabab" TEST = replace_first (create "ababab") ~in_:"acabababab" ~with_:"A" = "acAab" TEST = replace_first (create "abab") ~in_:"abababab" ~with_:"abababab" = "abababababab" let replace_all t ~in_:s ~with_ = let matches = index_all t ~may_overlap:false ~in_:s in match matches with | [] -> s | _::_ -> let len_s = length s in let len_t = length (fst t) in let len_with = length with_ in let num_matches = Core_list.length matches in let dst = make (len_s + (len_with - len_t) * num_matches) ' ' in let next_dst_pos = ref 0 in let next_src_pos = ref 0 in List.iter matches ~f:(fun i -> let len = i - !next_src_pos in blit ~src:s ~src_pos:!next_src_pos ~dst ~dst_pos:!next_dst_pos ~len; blit ~src:with_ ~src_pos:0 ~dst ~dst_pos:(!next_dst_pos + len) ~len:len_with; next_dst_pos := !next_dst_pos + len + len_with; next_src_pos := !next_src_pos + len + len_t; ); blit ~src:s ~src_pos:!next_src_pos ~dst ~dst_pos:!next_dst_pos ~len:(len_s - !next_src_pos); dst ;; TEST = replace_all (create "abab") ~in_:"abababab" ~with_:"" = "" TEST = replace_all (create "abab") ~in_:"abacabab" ~with_:"" = "abac" TEST = replace_all (create "abab") ~in_:"acabababab" ~with_:"A" = "acAA" TEST = replace_all (create "ababab") ~in_:"acabababab" ~with_:"A" = "acAab" TEST = replace_all (create "abaC") ~in_:"abaCabaDCababaCabaCaba" ~with_:"x" = "xabaDCabxxaba" TEST = replace_all (create "a") ~in_:"aa" ~with_:"aaa" = "aaaaaa" TEST = replace_all (create "") ~in_:"abcdeefff" ~with_:"X1" = "X1aX1bX1cX1dX1eX1eX1fX1fX1fX1" (* a doc comment in core_string.mli gives this as an example *) TEST = replace_all (create "bc") ~in_:"aabbcc" ~with_:"cb" = "aabcbc" end let substr_index ?pos t ~pattern = Search_pattern.index ?pos (Search_pattern.create pattern) ~in_:t ;; let substr_index_exn ?pos t ~pattern = Search_pattern.index_exn ?pos (Search_pattern.create pattern) ~in_:t ;; let substr_index_all t ~may_overlap ~pattern = Search_pattern.index_all (Search_pattern.create pattern) ~may_overlap ~in_:t ;; let substr_replace_first ?pos t ~pattern = Search_pattern.replace_first ?pos (Search_pattern.create pattern) ~in_:t ;; let substr_replace_all t ~pattern = Search_pattern.replace_all (Search_pattern.create pattern) ~in_:t ;; let is_substring t ~substring = Option.is_some (substr_index t ~pattern:substring) ;; let id x = x let of_string = id let to_string = id let iter t ~f = String.iter t ~f let init n ~f = if n < 0 then invalid_argf "String.init %d" n (); let t = create n in for i = 0 to n - 1 do t.[i] <- f i; done; t ;; (** See {!Core_array.normalize} for the following 4 functions. *) let normalize t i = Ordered_collection_common.normalize ~length_fun:String.length t i let slice t start stop = Ordered_collection_common.slice ~length_fun:String.length ~sub_fun:String.sub t start stop (*TEST = slice "hey" 0 0 = ""*) (* This is what I would expect *) TEST = slice "hey" 0 0 = "hey" (* But this is what we get! *) TEST = slice "hey" 0 1 = "h" TEST = slice "hey" 0 2 = "he" TEST = slice "hey" 0 3 = "hey" TEST = slice "hey" 1 1 = "" TEST = slice "hey" 1 2 = "e" TEST = slice "hey" 1 3 = "ey" TEST = slice "hey" 2 2 = "" TEST = slice "hey" 2 3 = "y" TEST = slice "hey" 3 3 = "" let nget x i = x.[normalize x i] let nset x i v = x.[normalize x i] <- v let invalid_argf = Core_printf.invalid_argf let to_list s = let rec loop acc i = if i < 0 then acc else loop (s.[i] :: acc) (i-1) in loop [] (String.length s - 1) let to_list_rev s = let len = String.length s in let rec loop acc i = if i = len then acc else loop (s.[i] :: acc) (i+1) in loop [] 0 let rev t = let len = String.length t in let res = String.create len in for i = 0 to len - 1 do unsafe_set res i (unsafe_get t (len - 1 - i)) done; res ;; TEST = rev "" = "";; TEST = rev "a" = "a";; TEST = rev "ab" = "ba";; TEST = rev "abc" = "cba";; (** Efficient string splitting *) let lsplit2_exn line ~on:delim = let pos = String.index line delim in (String.sub line ~pos:0 ~len:pos, String.sub line ~pos:(pos+1) ~len:(String.length line - pos - 1) ) let rsplit2_exn line ~on:delim = let pos = String.rindex line delim in (String.sub line ~pos:0 ~len:pos, String.sub line ~pos:(pos+1) ~len:(String.length line - pos - 1) ) let lsplit2 line ~on = try Some (lsplit2_exn line ~on) with Not_found -> None let rsplit2 line ~on = try Some (rsplit2_exn line ~on) with Not_found -> None let rec char_list_mem l (c:char) = match l with | [] -> false | hd::tl -> hd = c || char_list_mem tl c let split_gen str ~on = let is_delim = match on with | `char c' -> (fun c -> c = c') | `char_list l -> (fun c -> char_list_mem l c) in let len = String.length str in let rec loop acc last_pos pos = if pos = -1 then String.sub str ~pos:0 ~len:last_pos :: acc else if is_delim str.[pos] then let pos1 = pos + 1 in let sub_str = String.sub str ~pos:pos1 ~len:(last_pos - pos1) in loop (sub_str :: acc) pos (pos - 1) else loop acc last_pos (pos - 1) in loop [] len (len - 1) ;; let split str ~on = split_gen str ~on:(`char on) ;; let split_on_chars str ~on:chars = split_gen str ~on:(`char_list chars) ;; let split_lines = let back_up_at_newline ~t ~pos ~eol = pos := !pos - (if !pos > 0 && t.[!pos - 1] = '\r' then 2 else 1); eol := !pos + 1; in fun t -> let n = length t in if n = 0 then [] else (* Invariant: [-1 <= pos < eol]. *) let pos = ref (n - 1) in let eol = ref n in let ac = ref [] in (* We treat the end of the string specially, because if the string ends with a newline, we don't want an extra empty string at the end of the output. *) if t.[!pos] = '\n' then back_up_at_newline ~t ~pos ~eol; while !pos >= 0 do if t.[!pos] <> '\n' then decr pos else (* Becuase [pos < eol], we know that [start <= eol]. *) let start = !pos + 1 in ac := sub t ~pos:start ~len:(!eol - start) :: !ac; back_up_at_newline ~t ~pos ~eol done; sub t ~pos:0 ~len:!eol :: !ac ;; TEST_UNIT = List.iter ~f:(fun (t, expect) -> let actual = split_lines t in if actual <> expect then failwiths "split_lines bug" (t, `actual actual , `expect expect) <:sexp_of< t * [ `actual of t list ] * [ `expect of t list ] >>) [ "" , []; "\n" , [""]; "a" , ["a"]; "a\n" , ["a"]; "a\nb" , ["a"; "b"]; "a\nb\n" , ["a"; "b"]; "a\n\n" , ["a"; "" ]; "a\n\nb" , ["a"; "" ; "b"]; ] ;; TEST_UNIT = let lines = [ ""; "a"; "bc" ] in let newlines = [ "\n"; "\r\n" ] in let rec loop n expect to_concat = if n = 0 then begin let input = concat to_concat in let actual = Or_error.try_with (fun () -> split_lines input) in if actual <> Ok expect then failwiths "split_lines bug" (input, `actual actual , `expect expect) <:sexp_of< t * [ `actual of t list Or_error.t ] * [ `expect of t list ] >> end else begin loop (n - 1) expect to_concat; List.iter lines ~f:(fun t -> let loop to_concat = loop (n - 1) (t :: expect) (t :: to_concat) in if not (is_empty t) && List.is_empty to_concat then loop []; List.iter newlines ~f:(fun newline -> loop (newline :: to_concat))); end in loop 3 [] []; ;; (* [is_suffix s ~suff] returns [true] if the string [s] ends with the suffix [suff] *) let is_suffix s ~suffix = let len_suff = String.length suffix in let len_s = String.length s in len_s >= len_suff && (let rec loop i = i = len_suff || (suffix.[len_suff - 1 - i] = s.[len_s - 1 - i] && loop (i + 1)) in loop 0) let is_prefix s ~prefix = let len_pref = String.length prefix in String.length s >= len_pref && (let rec loop i = i = len_pref || (prefix.[i] = s.[i] && loop (i + 1)) in loop 0) ;; let wrap_sub_n t n ~name ~pos ~len ~on_error = if n < 0 then invalid_arg (name ^ " expecting nonnegative argument") else try sub t ~pos ~len with _ -> on_error let drop_prefix t n = wrap_sub_n ~name:"drop_prefix" t n ~pos:n ~len:(length t - n) ~on_error:"" let drop_suffix t n = wrap_sub_n ~name:"drop_suffix" t n ~pos:0 ~len:(length t - n) ~on_error:"" let prefix t n = wrap_sub_n ~name:"prefix" t n ~pos:0 ~len:n ~on_error:t let suffix t n = wrap_sub_n ~name:"suffix" t n ~pos:(length t - n) ~len:n ~on_error:t let lfindi ?(pos=0) t ~f = let n = length t in let rec loop i = if i = n then None else if f i t.[i] then Some i else loop (i + 1) in loop pos ;; TEST = lfindi "bob" ~f:(fun _ c -> 'b' = c) = Some 0 TEST = lfindi ~pos:0 "bob" ~f:(fun _ c -> 'b' = c) = Some 0 TEST = lfindi ~pos:1 "bob" ~f:(fun _ c -> 'b' = c) = Some 2 TEST = lfindi "bob" ~f:(fun _ c -> 'x' = c) = None let find t ~f = match lfindi t ~f:(fun _ c -> f c) with | None -> None | Some i -> Some t.[i] let find_map t ~f = let n = length t in let rec loop i = if i = n then None else match f t.[i] with | None -> loop (i + 1) | Some _ as res -> res in loop 0 ;; TEST = find_map "fop" ~f:(fun c -> if c >= 'o' then Some c else None) = Some 'o' TEST = find_map "bar" ~f:(fun _ -> None) = None TEST = find_map "" ~f:(fun _ -> assert false) = None let rfindi ?pos t ~f = let rec loop i = if i < 0 then None else begin if f i t.[i] then Some i else loop (i - 1) end in let pos = match pos with | Some pos -> pos | None -> length t - 1 in loop pos ;; TEST = rfindi "bob" ~f:(fun _ c -> 'b' = c) = Some 2 TEST = rfindi ~pos:2 "bob" ~f:(fun _ c -> 'b' = c) = Some 2 TEST = rfindi ~pos:1 "bob" ~f:(fun _ c -> 'b' = c) = Some 0 TEST = rfindi "bob" ~f:(fun _ c -> 'x' = c) = None let last_non_drop ~drop t = rfindi t ~f:(fun _ c -> not (drop c)) let rstrip ?(drop=Char.is_whitespace) t = match last_non_drop t ~drop with | None -> "" | Some i -> if i = length t - 1 then t else prefix t (i + 1) ;; let first_non_drop ~drop t = lfindi t ~f:(fun _ c -> not (drop c)) let lstrip ?(drop=Char.is_whitespace) t = match first_non_drop t ~drop with | None -> "" | Some 0 -> t | Some n -> drop_prefix t n ;; (* [strip t] could be implemented as [lstrip (rstrip t)]. The implementation below saves (at least) a factor of two allocation, by only allocating the final result. This also saves some amount of time. *) let strip ?(drop=Char.is_whitespace) t = let length = length t in if length = 0 || not (drop t.[0] || drop t.[length - 1]) then t else match first_non_drop t ~drop with | None -> "" | Some first -> match last_non_drop t ~drop with | None -> assert false | Some last -> sub t ~pos:first ~len:(last - first + 1) ;; TEST = strip " foo bar \n" = "foo bar" TEST = strip ~drop:(fun c -> c = '"') "\" foo bar " = " foo bar " TEST = strip ~drop:(fun c -> c = '"') " \" foo bar " = " \" foo bar " let mapi t ~f = let l = String.length t in let t' = String.create l in for i = 0 to l - 1 do t'.[i] <- f i t.[i] done; t' (* repeated code to avoid requiring an extra allocation for a closure on each call. *) let map t ~f = let l = String.length t in let t' = String.create l in for i = 0 to l - 1 do t'.[i] <- f t.[i] done; t' let to_array s = Array.init (String.length s) ~f:(fun i -> s.[i]) let tr ~target ~replacement s = map ~f:(fun c -> if c = target then replacement else c) s let tr_inplace ~target ~replacement s = (* destructive version of tr *) for i = 0 to String.length s - 1 do if s.[i] = target then s.[i] <- replacement done let exists s ~f = let length = length s in let rec loop i = i < length && (f s.[i] || loop (i + 1)) in loop 0 ;; TEST = false = exists "" ~f:(fun _ -> assert false) TEST = false = exists "abc" ~f:(Fn.const false) TEST = true = exists "abc" ~f:(Fn.const true) TEST = true = exists "abc" ~f:(function 'a' -> false | 'b' -> true | _ -> assert false) let for_all s ~f = let length = length s in let rec loop i = i = length || (f s.[i] && loop (i + 1)) in loop 0 ;; TEST = true = for_all "" ~f:(fun _ -> assert false) TEST = true = for_all "abc" ~f:(Fn.const true) TEST = false = for_all "abc" ~f:(Fn.const false) TEST = false = for_all "abc" ~f:(function 'a' -> true | 'b' -> false | _ -> assert false) let fold t ~init ~f = let n = length t in let rec loop i ac = if i = n then ac else loop (i + 1) (f ac t.[i]) in loop 0 init ;; let foldi t ~init ~f = let n = length t in let rec loop i ac = if i = n then ac else loop (i + 1) (f i ac t.[i]) in loop 0 init ;; TEST = (foldi "hello" ~init:[] ~f:(fun i acc ch -> (i,ch)::acc) = List.rev [0,'h';1,'e';2,'l';3,'l';4,'o']) let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t = Container.min_elt ~fold t let max_elt t = Container.max_elt ~fold t let mem ?(equal = Char.(=)) t c = let rec loop i = i < length t && (equal c t.[i] || loop (i + 1)) in loop 0 ;; let concat_array ?sep ar = concat ?sep (Array.to_list ar) let concat_map ?sep s ~f = concat_array ?sep (Array.map (to_array s) ~f) (* [filter t f] is implemented by the following algorithm. Let [n = length t]. 1. Find the lowest [i] such that [not (f t.[i])]. 2. If there is no such [i], then return [t]. 3. If there is such an [i], allocate a string, [out], to hold the result. [out] has length [n - 1], which is the maximum possible output size given that there is at least one character not satisfying [f]. 4. Copy characters at indices 0 ... [i - 1] from [t] to [out]. 5. Walk through characters at indices [i+1] ... [n-1] of [t], copying those that satisfy [f] from [t] to [out]. 6. If we completely filled [out], then return it. If not, return the prefix of [out] that we did fill in. This algorithm has the property that it doesn't allocate a new string if there's nothing to filter, which is a common case. *) let filter t ~f = let n = length t in let i = ref 0 in while !i < n && f t.[!i]; do incr i done; if !i = n then t else begin let out = make (n - 1) ' ' in blit ~src:t ~src_pos:0 ~dst:out ~dst_pos:0 ~len:!i; let out_pos = ref !i in incr i; while !i < n; do let c = t.[!i] in if f c then (out.[!out_pos] <- c; incr out_pos); incr i done; if !out_pos = n - 1 then out else sub out ~pos:0 ~len:!out_pos end ;; TEST = filter "hello" ~f:(fun c -> c <> 'h') = "ello" TEST = filter "hello" ~f:(fun c -> c <> 'l') = "heo" TEST = filter "hello" ~f:(fun _ -> false) = "" TEST = filter "hello" ~f:(fun _ -> true) = "hello" TEST = let s = "hello" in (filter s ~f:(fun _ -> true)) == s TEST_UNIT = let s = "abc" in let r = ref 0 in assert (phys_equal s (filter s ~f:(fun _ -> incr r; true))); assert (!r = String.length s); ;; let chop_prefix s ~prefix = if is_prefix s ~prefix then Some (drop_prefix s (String.length prefix)) else None let chop_prefix_exn s ~prefix = match chop_prefix s ~prefix with | Some str -> str | None -> raise (Invalid_argument (Printf.sprintf "Core_string.chop_prefix_exn %S %S" s prefix)) let chop_suffix s ~suffix = if is_suffix s ~suffix then Some (drop_suffix s (String.length suffix)) else None let chop_suffix_exn s ~suffix = match chop_suffix s ~suffix with | Some str -> str | None -> raise (Invalid_argument (Printf.sprintf "Core_string.chop_suffix_exn %S %S" s suffix)) (* There used to be a custom implementation that was faster for very short strings (peaking at 40% faster for 4-6 char long strings). This new function is around 20% faster than the default hash function, but slower than the previous custom implementation. However, the new OCaml function is well behaved, and this implementation is less likely to diverge from the default OCaml implementation does, which is a desirable property. (The only way to avoid the divergence is to expose the macro redefined in hash_stubs.c in the hash.h header of the OCaml compiler.) *) module Hash = struct external hash : string -> int = "caml_hash_string" "noalloc" TEST_UNIT = List.iter ~f:(fun string -> assert (hash string = Caml.Hashtbl.hash string)) [ "Oh Gloria inmarcesible! Oh jubilo inmortal!" ; "Oh say can you see, by the dawn's early light" ] ;; end module Infix = struct let ( ) str (start,stop) = slice str start stop end include (Hashable.Make_binable (struct include T include Hash end) : Hashable.S_binable with type t := t) (* [include Hash] to make the [external] version override the [hash] from [Hashable.Make_binable], so that we get a little bit of a speedup by exposing it as external in the mli. *) include Hash include Comparable.Map_and_set_binable (T) include Comparable.Validate (T) (* for interactive top-levels -- modules deriving from String should have String's pretty printer. *) let pp = Format.pp_print_string (* fast version, if we ever need it: let concat_array ~sep ar = let ar_len = Array.length ar in if ar_len = 0 then "" else let sep_len = String.length sep in let res_len_ref = ref (sep_len * (ar_len - 1)) in for i = 0 to ar_len - 1 do res_len_ref := !res_len_ref + String.length ar.(i) done; let res = String.create !res_len_ref in let str_0 = ar.(0) in let len_0 = String.length str_0 in String.blit ~src:str_0 ~src_pos:0 ~dst:res ~dst_pos:0 ~len:len_0; let pos_ref = ref len_0 in for i = 1 to ar_len - 1 do let pos = !pos_ref in String.blit ~src:sep ~src_pos:0 ~dst:res ~dst_pos:pos ~len:sep_len; let new_pos = pos + sep_len in let str_i = ar.(i) in let len_i = String.length str_i in String.blit ~src:str_i ~src_pos:0 ~dst:res ~dst_pos:new_pos ~len:len_i; pos_ref := new_pos + len_i done; res *) let of_char c = String.make 1 c let of_char_list l = let t = create (List.length l) in List.iteri l ~f:(fun i c -> t.[i] <- c); t TEST = of_char_list ['a';'b';'c'] = "abc" TEST = of_char_list [] = "" module Escaping = struct (* If this is changed, make sure to update [escape], which attempts to ensure all the invariants checked here. *) let build_and_validate_escapeworthy_map escapeworthy_map escape_char func = let escapeworthy_map = if List.Assoc.mem escapeworthy_map escape_char then escapeworthy_map else (escape_char, escape_char) :: escapeworthy_map in let arr = Array.create 256 (-1) in let rec loop vals = function | [] -> Ok arr | (c_from, c_to) :: l -> let k, v = match func with | `Escape -> Char.to_int c_from, c_to | `Unescape -> Char.to_int c_to, c_from in if arr.(k) <> -1 || Char.Set.mem vals v then Or_error.error "escapeworthy_map not one-to-one" (c_from, c_to, escapeworthy_map) (<:sexp_of< char * char * (char * char) list >>) else (arr.(k) <- Char.to_int v; loop (Char.Set.add vals v) l) in loop Char.Set.empty escapeworthy_map ;; let escape_gen ~escapeworthy_map ~escape_char = match build_and_validate_escapeworthy_map escapeworthy_map escape_char `Escape with | Error _ as x -> x | Ok escapeworthy -> Ok (fun src -> (* calculate a list of (index of char to escape * escaped char) first, the order is from tail to head *) let to_escape_len = ref 0 in let to_escape = foldi src ~init:[] ~f:(fun i acc c -> match escapeworthy.(Char.to_int c) with | -1 -> acc | n -> (* (index of char to escape * escaped char) *) incr to_escape_len; (i, Char.unsafe_of_int n) :: acc) in match to_escape with | [] -> src | _ -> (* [to_escape] divide [src] to [List.length to_escape + 1] pieces separated by the chars to escape. Lets take {[ escape_gen_exn ~escapeworthy_map:[('a', 'A'); ('b', 'B'); ('c', 'C')] ~escape_char:'_' ]} for example, and assume the string to escape is "000a111b222c333" then [to_escape] is [(11, 'C'); (7, 'B'); (3, 'A')]. Then we create a [dst] of length [String.length src + 3] to store the result, copy piece "333" to [dst] directly, then copy '_' and 'C' to [dst]; then move on to next; after 3 iterations, copy piece "000" and we are done. Finally the result will be "000_A111_B222_C333" *) let src_len = String.length src in let dst_len = src_len + !to_escape_len in let dst = String.create dst_len in let rec loop last_idx last_dst_pos = function | [] -> (* copy "000" at last *) blit ~src ~src_pos:0 ~dst ~dst_pos:0 ~len:last_idx | (idx, escaped_char) :: to_escape -> (*[idx] = the char to escape*) (* take first iteration for example *) (* calculate length of "333", minus 1 because we don't copy 'c' *) let len = last_idx - idx - 1 in (* set the dst_pos to copy to *) let dst_pos = last_dst_pos - len in (* copy "333", set [src_pos] to [idx + 1] to skip 'c' *) blit ~src ~src_pos:(idx + 1) ~dst ~dst_pos ~len; (* backoff [dst_pos] by 2 to copy '_' and 'C' *) let dst_pos = dst_pos - 2 in dst.[dst_pos] <- escape_char; dst.[dst_pos + 1] <- escaped_char; loop idx dst_pos to_escape in (* set [last_dst_pos] and [last_idx] to length of [dst] and [src] first *) loop src_len dst_len to_escape; dst ) ;; let escape_gen_exn ~escapeworthy_map ~escape_char = Or_error.ok_exn (escape_gen ~escapeworthy_map ~escape_char) |! stage ;; TEST_MODULE "escape_gen" = struct let escape = unstage (escape_gen_exn ~escapeworthy_map:[('%','p');('^','c')] ~escape_char:'_') TEST = escape "" = "" TEST = escape "foo" = "foo" TEST = escape "_" = "__" TEST = escape "foo%bar" = "foo_pbar" TEST = escape "^foo%" = "_cfoo_p" let escape2 = unstage (escape_gen_exn ~escapeworthy_map:[('_','.');('%','p');('^','c')] ~escape_char:'_') TEST = escape2 "_." = "_.." TEST = escape2 "_" = "_." TEST = escape2 "foo%_bar" = "foo_p_.bar" TEST = escape2 "_foo%" = "_.foo_p" let checks_for_one_to_one escapeworthy_map = try let _escape = escape_gen_exn ~escapeworthy_map ~escape_char:'_' in false with _ -> true TEST = checks_for_one_to_one [('%','p');('^','c');('$','c')] TEST = checks_for_one_to_one [('%','p');('^','c');('%','d')] end let escape ~escapeworthy ~escape_char = (* For [escape_gen_exn], we don't know how to fix invalid escapeworthy_map so we have to raise exception; but in this case, we know how to fix duplicated elements in escapeworthy list, so we just fix it instead of raising exception to make this function easier to use. *) let escapeworthy_map = List.map ~f:(fun c -> (c, c)) (Char.Set.to_list (Char.Set.remove (Char.Set.of_list escapeworthy) escape_char)) in escape_gen_exn ~escapeworthy_map ~escape_char ;; (* In an escaped string, any char is either `Escaping, `Escaped or `Literal. For example, the escape statuses of chars in string "a_a__" with escape_char = '_' are a : `Literal _ : `Escaping a : `Escaped _ : `Escaping _ : `Escaped [update_escape_status str ~escape_char i previous_status] gets escape status of str.[i] basing on escape status of str.[i - 1] *) let update_escape_status str ~escape_char i = function | `Escaping -> `Escaped | `Literal | `Escaped -> if str.[i] = escape_char then `Escaping else `Literal ;; let unescape_gen ~escapeworthy_map ~escape_char = match build_and_validate_escapeworthy_map escapeworthy_map escape_char `Unescape with | Error _ as x -> x | Ok escapeworthy -> Ok (fun src -> (* Continue the example in [escape_gen_exn], now we unescape "000_A111_B222_C333" back to "000a111b222c333" Then [to_unescape] is [14; 9; 4], which is indexes of '_'s. Then we create a string [dst] to store the result, copy "333" to it, then copy 'c', then move on to next iteration. After 3 iterations copy "000" and we are done. *) (* indexes of escape chars *) let to_unescape = let rec loop i status acc = if i >= String.length src then acc else let status = update_escape_status src ~escape_char i status in loop (i + 1) status (if status = `Escaping then i :: acc else acc) in loop 0 `Literal [] in match to_unescape with | [] -> src | idx::to_unescape' -> let dst = create (String.length src - List.length to_unescape) in let rec loop last_idx last_dst_pos = function | [] -> (* copy "000" at last *) blit ~src ~src_pos:0 ~dst ~dst_pos:0 ~len:last_idx | idx::to_unescape -> (* [idx] = index of escaping char *) (* take 1st iteration as example, calculate the length of "333", minus 2 to skip '_C' *) let len = last_idx - idx - 2 in (* point [dst_pos] to the position to copy "333" to *) let dst_pos = last_dst_pos - len in (* copy "333" *) blit ~src ~src_pos:(idx + 2) ~dst ~dst_pos ~len; (* backoff [dst_pos] by 1 to copy 'c' *) let dst_pos = dst_pos - 1 in dst.[dst_pos] <- ( match escapeworthy.(Char.to_int src.[idx + 1]) with | -1 -> src.[idx + 1] | n -> Char.unsafe_of_int n); (* update [last_dst_pos] and [last_idx] *) loop idx dst_pos to_unescape in ( if idx < String.length src - 1 then (* set [last_dst_pos] and [last_idx] to length of [dst] and [src] *) loop (String.length src) (String.length dst) to_unescape else (* for escaped string ending with an escaping char like "000_", just ignore the last escaping char *) loop (String.length src - 1) (String.length dst) to_unescape' ); dst ) ;; let unescape_gen_exn ~escapeworthy_map ~escape_char = Or_error.ok_exn (unescape_gen ~escapeworthy_map ~escape_char) |! stage ;; TEST_MODULE "unescape_gen" = struct let unescape = unstage (unescape_gen_exn ~escapeworthy_map:['%','p';'^','c'] ~escape_char:'_') TEST = unescape "__" = "_" TEST = unescape "foo" = "foo" TEST = unescape "__" = "_" TEST = unescape "foo_pbar" = "foo%bar" TEST = unescape "_cfoo_p" = "^foo%" let unescape2 = unstage (unescape_gen_exn ~escapeworthy_map:['_','.';'%','p';'^','c'] ~escape_char:'_') (* this one is ill-formed, just ignore the escape_char without escaped char *) TEST = unescape2 "_" = "" TEST = unescape2 "a_" = "a" TEST = unescape2 "__" = "_" TEST = unescape2 "_.." = "_." TEST = unescape2 "_." = "_" TEST = unescape2 "foo_p_.bar" = "foo%_bar" TEST = unescape2 "_.foo_p" = "_foo%" (* generate [n] random string and check if escaping and unescaping are consistent *) let random_test ~escapeworthy_map ~escape_char n = let escape = unstage (escape_gen_exn ~escapeworthy_map ~escape_char) in let unescape = unstage (unescape_gen_exn ~escapeworthy_map ~escape_char) in let test str = let escaped = escape str in let unescaped = unescape escaped in if str <> unescaped then failwith ( Printf.sprintf "string: %s\nescaped string: %s\nunescaped string: %s" str escaped unescaped) in let array_random_elem arr = arr.(Random.int (Array.length arr)) in let random_char = let print_chars = List.range (Char.to_int Char.min_value) (Char.to_int Char.max_value + 1) |! List.filter_map ~f:Char.of_int |! List.filter ~f:Char.is_print |! Array.of_list in fun () -> array_random_elem print_chars in let escapeworthy_chars = List.map escapeworthy_map ~f:fst |! Array.of_list in try for _i = 0 to n - 1 do let str = List.init (Random.int 50) ~f:(fun _ -> let p = Random.int 100 in if p < 10 then escape_char else if p < 25 then array_random_elem escapeworthy_chars else random_char () ) |! of_char_list in test str done; true with e -> raise e TEST = random_test 1000 ~escapeworthy_map:['%','p';'^','c'] ~escape_char:'_' TEST = random_test 1000 ~escapeworthy_map:['_','.';'%','p';'^','c'] ~escape_char:'_' end let unescape ~escape_char = unescape_gen_exn ~escapeworthy_map:[] ~escape_char TEST_MODULE "unescape" = struct let unescape = unstage (unescape ~escape_char:'_') TEST = unescape "foo" = "foo" TEST = unescape "__" = "_" TEST = unescape "foo_%bar" = "foo%bar" TEST = unescape "_^foo_%" = "^foo%" end let preceding_escape_chars str ~escape_char pos = let rec loop p cnt = if (p < 0) || (str.[p] <> escape_char) then cnt else loop (p - 1) (cnt + 1) in loop (pos - 1) 0 ;; (* In an escaped string, any char is either `Escaping, `Escaped or `Literal. For example, the escape statuses of chars in string "a_a__" with escape_char = '_' are a : `Literal _ : `Escaping a : `Escaped _ : `Escaping _ : `Escaped [update_escape_status str ~escape_char i previous_status] gets escape status of str.[i] basing on escape status of str.[i - 1] *) let update_escape_status str ~escape_char i = function | `Escaping -> `Escaped | `Literal | `Escaped -> if str.[i] = escape_char then `Escaping else `Literal ;; let escape_status str ~escape_char pos = let odd = (preceding_escape_chars str ~escape_char pos) mod 2 = 1 in match odd, str.[pos] = escape_char with | true, (true|false) -> `Escaped | false, true -> `Escaping | false, false -> `Literal ;; let check_bound str pos function_name = if pos >= String.length str || pos < 0 then invalid_argf "%s: out of bounds" function_name () ;; let is_char_escaping str ~escape_char pos = check_bound str pos "is_char_escaping"; escape_status str ~escape_char pos = `Escaping ;; TEST_MODULE "is_char_escaping" = struct let is = is_char_escaping ~escape_char:'_' TEST = is "___" 0 = true TEST = is "___" 1 = false TEST = is "___" 2 = true (* considered escaping, though there's nothing to escape *) TEST = is "a_b__c" 0 = false TEST = is "a_b__c" 1 = true TEST = is "a_b__c" 2 = false TEST = is "a_b__c" 3 = true TEST = is "a_b__c" 4 = false TEST = is "a_b__c" 5 = false end let is_char_escaped str ~escape_char pos = check_bound str pos "is_char_escaped"; escape_status str ~escape_char pos = `Escaped ;; TEST_MODULE "is_char_escaped" = struct let is = is_char_escaped ~escape_char:'_' TEST = is "___" 2 = false TEST = is "x" 0 = false TEST = is "_x" 1 = true TEST = is "sadflkas____sfff" 12 = false TEST = is "s_____s" 6 = true end let is_char_literal str ~escape_char pos = check_bound str pos "is_char_literal"; escape_status str ~escape_char pos = `Literal ;; TEST_MODULE "is_char_literal" = struct let is_char_literal = is_char_literal ~escape_char:'_' TEST = is_char_literal "123456" 4 = true TEST = is_char_literal "12345_6" 6 = false TEST = is_char_literal "12345_6" 5 = false TEST = is_char_literal "123__456" 4 = false TEST = is_char_literal "123456__" 7 = false TEST = is_char_literal "__123456" 1 = false TEST = is_char_literal "__123456" 0 = false TEST = is_char_literal "__123456" 2 = true end let index_from str ~escape_char pos char = check_bound str pos "index_from"; let rec loop i status = if i >= pos && status = `Literal && str.[i] = char then Some i else ( let i = i + 1 in if i >= length str then None else loop i (update_escape_status str ~escape_char i status)) in loop pos (escape_status str ~escape_char pos) ;; let index_from_exn str ~escape_char pos char = match index_from str ~escape_char pos char with | None -> failwiths "index_from_exn: not found" (str, `escape_char escape_char, `pos pos, char) <:sexp_of> | Some pos -> pos ;; let index str ~escape_char char = index_from str ~escape_char 0 char let index_exn str ~escape_char char = index_from_exn str ~escape_char 0 char TEST_MODULE "index_from" = struct let f = index_from ~escape_char:'_' TEST = f "__" 0 '_' = None TEST = f "_.." 0 '.' = Some 2 TEST = f "1273456_7789" 3 '7' = Some 9 TEST = f "1273_7456_7789" 3 '7' = Some 11 TEST = f "1273_7456_7789" 3 'z' = None end let rindex_from str ~escape_char pos char = check_bound str pos "rindex_from"; (* if the target char is the same as [escape_char], we have no way to determine which escape_char is literal, so just return None *) if char = escape_char then None else let rec loop pos = if pos < 0 then None else ( let escape_chars = preceding_escape_chars str ~escape_char pos in if escape_chars mod 2 = 0 && str.[pos] = char then Some pos else loop (pos - escape_chars - 1)) in loop pos ;; let rindex_from_exn str ~escape_char pos char = match rindex_from str ~escape_char pos char with | None -> failwiths "rindex_from_exn: not found" (str, `escape_char escape_char, `pos pos, char) <:sexp_of> | Some pos -> pos ;; let rindex str ~escape_char char = rindex_from str ~escape_char (String.length str - 1) char ;; let rindex_exn str ~escape_char char = rindex_from_exn str ~escape_char (String.length str - 1) char ;; TEST_MODULE "rindex_from" = struct let f = rindex_from ~escape_char:'_' TEST = f "__" 0 '_' = None TEST = f "123456_37839" 9 '3' = Some 2 TEST = f "123_2321" 6 '2' = Some 6 TEST = f "123_2321" 5 '2' = Some 1 end (* [split_gen str ~escape_char ~on] works similarly to [String.split_gen], with an additional requirement: only split on literal chars, not escaping or escaped *) let split_gen str ~escape_char ~on = let is_delim = match on with | `char c' -> (fun c -> c = c') | `char_list l -> (fun c -> char_list_mem l c) in let len = String.length str in let rec loop acc status last_pos pos = if pos = len then List.rev (String.sub str ~pos:last_pos ~len:(len - last_pos) :: acc) else let status = update_escape_status str ~escape_char pos status in if status = `Literal && is_delim str.[pos] then let sub_str = String.sub str ~pos:last_pos ~len:(pos - last_pos) in loop (sub_str :: acc) status (pos + 1) (pos + 1) else loop acc status last_pos (pos + 1) in loop [] `Literal 0 0 ;; let split str ~on = split_gen str ~on:(`char on) ;; let split_on_chars str ~on:chars = split_gen str ~on:(`char_list chars) ;; TEST_MODULE "split_on_gen" = struct let split = split_gen ~escape_char:'_' ~on:(`char ',') TEST = split "foo,bar,baz" = ["foo"; "bar"; "baz"] TEST = split "foo_,bar,baz" = ["foo_,bar"; "baz"] TEST = split "foo_,bar_,baz" = ["foo_,bar_,baz"] TEST = split "foo__,bar,baz" = ["foo__"; "bar"; "baz"] TEST = split "foo,bar,baz_," = ["foo"; "bar"; "baz_,"] TEST = split "foo,bar_,baz_,," = ["foo"; "bar_,baz_,"; ""] let split = split_gen ~escape_char:'_' ~on:(`char_list [',';':']) TEST = split "foo,bar:baz" = ["foo"; "bar"; "baz"] TEST = split "foo_,bar,baz" = ["foo_,bar"; "baz"] TEST = split "foo_:bar_,baz" = ["foo_:bar_,baz"] TEST = split "foo,bar,baz_," = ["foo"; "bar"; "baz_,"] TEST = split "foo:bar_,baz_,," = ["foo"; "bar_,baz_,"; ""] end let split_at str pos = String.sub str ~pos:0 ~len:pos, String.sub str ~pos:(pos + 1) ~len:(String.length str - pos - 1) ;; let lsplit2 str ~on ~escape_char = Option.map (index str ~escape_char on) ~f:(fun x -> split_at str x) ;; let rsplit2 str ~on ~escape_char = Option.map (rindex str ~escape_char on) ~f:(fun x -> split_at str x) ;; let lsplit2_exn str ~on ~escape_char = split_at str (index_exn str ~escape_char on) ;; let rsplit2_exn str ~on ~escape_char = split_at str (rindex_exn str ~escape_char on) ;; TEST_MODULE "split2" = struct let escape_char = '_' let on = ',' TEST = lsplit2 ~escape_char ~on "foo_,bar,baz_,0" = Some ("foo_,bar", "baz_,0") TEST = rsplit2 ~escape_char ~on "foo_,bar,baz_,0" = Some ("foo_,bar", "baz_,0") TEST = lsplit2_exn ~escape_char ~on "foo_,bar,baz_,0" = ("foo_,bar", "baz_,0") TEST = rsplit2_exn ~escape_char ~on "foo_,bar,baz_,0" = ("foo_,bar", "baz_,0") TEST = lsplit2 ~escape_char ~on "foo_,bar" = None TEST = rsplit2 ~escape_char ~on "foo_,bar" = None TEST = try lsplit2_exn ~escape_char ~on "foo_,bar" |! Fn.const false with _ -> true TEST = try rsplit2_exn ~escape_char ~on "foo_,bar" |! Fn.const false with _ -> true end end ;; module Replace_polymorphic_compare = struct let equal = equal let min (x : t) y = if x < y then x else y let max (x : t) y = if x > y then x else y let compare (x : t) y = compare x y let ascending = compare let descending x y = compare y x let ( >= ) x y = (x : t) >= y let ( <= ) x y = (x : t) <= y let ( = ) x y = (x : t) = y let ( > ) x y = (x : t) > y let ( < ) x y = (x : t) < y let ( <> ) x y = (x : t) <> y let between t ~low ~high = low <= t && t <= high let _squelch_unused_module_warning_ = () end include Replace_polymorphic_compare core_kernel-113.00.00/src/core_string.mli000066400000000000000000000415441256461164500201360ustar00rootroot00000000000000(** An extension of the standard StringLabels. If you open Core.Std, you'll get these in the String module. *) type t = string with bin_io, sexp, typerep (** [Caseless] compares and hashes strings ignoring case, so that for example [Caseless.equal "OCaml" "ocaml"] and [Caseless.("apple" < "Banana")] are [true], and [Caseless.Map], [Caseless.Table] lookup and [Caseless.Set] membership is case-insensitive. *) module Caseless : sig include Comparable.S_binable with type t := t include Hashable. S_binable with type t := t end include Blit.S with type t := t include Container.S0 with type t := t with type elt = char include Identifiable.S with type t := t (** Maximum length of a string. *) val max_length : int external length : t -> int = "%string_length" external get : t -> int -> char = "%string_safe_get" external set : t -> int -> char -> unit = "%string_safe_set" external create : int -> t = "caml_create_string" val make : int -> char -> t val copy : t -> t val init : int -> f:(int -> char) -> t val fill : t -> pos:int -> len:int -> char -> unit (** String append. Also available unqualified, but re-exported here for documentation purposes. Note that [a ^ b] must copy both [a] and [b] into a newly-allocated result string, so [a ^ b ^ c ^ ... ^ z] is quadratic in the number of strings. [String.concat] does not have this problem -- it allocates the result buffer only once. The [Rope] module provides a data structure which uses a similar trick to achieve fast concatenation at either end of a string. *) val ( ^ ) : t -> t -> t (** concatanate all strings in the list using separator [sep] (default sep "") *) val concat : ?sep:t -> t list -> t (* (** Like concat, but uses the Container typeclass *) val tc_concat : (t, 'container) Container.tc -> sep:t -> 'container -> t *) (** Warning: Only returns a copy if changes are necessary! Special characters are represented by escape sequences, following the lexical conventions of Objective Caml. *) val escaped : t -> t val contains : ?pos:int -> ?len:int -> t -> char -> bool val uppercase : t -> t val lowercase : t -> t val capitalize : t -> t val uncapitalize : t -> t val index : t -> char -> int option val index_exn : t -> char -> int val rindex : t -> char -> int option val rindex_exn : t -> char -> int val index_from : t -> int -> char -> int option val index_from_exn : t -> int -> char -> int val rindex_from : t -> int -> char -> int option val rindex_from_exn : t -> int -> char -> int (** Substring search and replace functions. They use the Knuth-Morris-Pratt algorithm (KMP) under the hood. The functions in the [Search_pattern] module allow the program to preprocess the searched pattern once and then use it many times without further allocations. *) module Search_pattern : sig type t with sexp_of (** [create pattern] preprocesses [pattern] as per KMP, building an [int array] of length [length pattern]. All inputs are valid. *) val create : string -> t (** [pos < 0] or [pos >= length string] result in no match (hence [index] returns [None] and [index_exn] raises). *) val index : ?pos:int -> t -> in_:string -> int option val index_exn : ?pos:int -> t -> in_:string -> int (** [may_overlap] determines whether after a successful match, [index_all] should start looking for another one at the very next position ([~may_overlap:true]), or jump to the end of that match and continue from there ([~may_overlap:false]), e.g.: {| index_all (create "aaa") ~may_overlap:false ~in_:"aaaaBaaaaaa" = [0; 5; 8] index_all (create "aaa") ~may_overlap:true ~in_:"aaaaBaaaaaa" = [0; 1; 5; 6; 7; 8] |} E.g. [replace_all] internally calls [index_all ~may_overlap:false]. *) val index_all : t -> may_overlap:bool -> in_:string -> int list (** Note that the result of [replace_all pattern ~in_:text ~with_:r] may still contain [pattern], e.g. {[ replace_all (create "bc") ~in:"aabbcc" ~with_:"cb" = "aabcbc" ]} *) val replace_first : ?pos:int -> t -> in_:string -> with_:string -> string val replace_all : t -> in_:string -> with_:string -> string end (** Substring search and replace convenience functions. They call [Search_pattern.create] and then forget the preprocessed pattern when the search is complete. [pos < 0] or [pos >= length t] result in no match (hence [substr_index] returns [None] and [substr_index_exn] raises). [may_overlap] indicates whether to report overlapping matches, see [Search_pattern.index_all]. *) val substr_index : ?pos:int -> t -> pattern:t -> int option val substr_index_exn : ?pos:int -> t -> pattern:t -> int val substr_index_all : t -> may_overlap:bool -> pattern:t -> int list val substr_replace_first : ?pos:int -> t -> pattern:t -> with_:t -> t (** As with [Search_pattern.replace_all], the result may still contain [pattern]. *) val substr_replace_all : t -> pattern:t -> with_:t -> t (** [is_substring ~substring:"bar" "foo bar baz"] is true *) val is_substring : t -> substring:t -> bool (** [slice s start stop] gets a slice of [s] between [start] and [stop]. [start] and [stop] will be normalized before the access. (viz. Core_array.normalize). *) val slice : t -> int -> int -> t (** Returns the reversed list of characters contained in a list. *) val to_list_rev : t -> char list (** [rev t] returns [t] in reverse order. *) val rev : t -> t (** [nget s i] Gets the char at normalized position [i] in [s]. *) val nget : t -> int -> char (** [nset s i c] Sets the char at normalized position [i] to [c]. *) val nset : t -> int -> char -> unit (** [is_suffix s ~suffix] returns [true] if [s] ends with [suffix]. *) val is_suffix : t -> suffix:t -> bool (** [is_prefix s ~prefix] returns [true] if [s] starts with [prefix]. *) val is_prefix : t -> prefix:t -> bool (** If the string [s] contains the character [on], then [lsplit2_exn s ~on] returns a pair containing [s] split around the first appearance of [on] (from the left). @raise Not_found When [on] cannot be found in [s] *) val lsplit2_exn : t -> on:char -> t * t (** If the string [s] contains the character [on], then [rsplit2_exn s ~on] returns a pair containing [s] split around the first appearance of [on] (from the right). @raise Not_found When [on] cannot be found in [s] *) val rsplit2_exn : t -> on:char -> t * t (** [lsplit2 line ~on] optionally returns [line] split into two strings around the * first appearance of [on] from the left *) val lsplit2 : t -> on:char -> (t * t) option (** [rsplit2 line ~on] optionally returns [line] split into two strings around the * first appearance of [on] from the right *) val rsplit2 : t -> on:char -> (t * t) option (** [split s ~on] @return a list of substrings of [s] that are separated by [on]. Consecutive [on] characters will cause multiple empty strings in the result. Splitting the empty string returns a list of the empty string, not the empty list. *) val split : t -> on:char -> t list (** [split_on_chars s ~on] @return a list of all substrings of [s] that are separated by one of the chars from [on]. [on] are not grouped. So a grouping of [on] in the source string will produce multiple empty string splits in the result. *) val split_on_chars : t -> on:char list -> t list (** [split_lines t] returns the list of lines that comprise [t]. The lines do not include the trailing ["\n"] or ["\r\n"]. *) val split_lines : t -> t list (** [lfindi ?pos t ~f] returns the smallest [i >= pos] such that [f i t.[i]], if there is such an [i]. By default, [pos = 0]. *) val lfindi : ?pos : int -> t -> f:(int -> char -> bool) -> int option (** [rfindi ?pos t ~f] returns the largest [i <= pos] such that [f i t.[i]], if there is such an [i]. By default [pos = length t - 1]. *) val rfindi : ?pos : int -> t -> f:(int -> char -> bool) -> int option (** Warning: the following strip functions have copy-on-write semantics (i.e. they may return the same string passed in) *) (** [lstrip ?drop s] returns a string with consecutive chars satisfying [drop] (by default white space, e.g. tabs, spaces, newlines, and carriage returns) stripped from the beginning of [s]. *) val lstrip : ?drop:(char -> bool) -> t -> t (** [rstrip ?drop s] returns a string with consecutive chars satisfying [drop] (by default white space, e.g. tabs, spaces, newlines, and carriage returns) stripped from the end of [s]. *) val rstrip : ?drop:(char -> bool) -> t -> t (** [strip ?drop s] returns a string with consecutive chars satisfying [drop] (by default white space, e.g. tabs, spaces, newlines, and carriage returns) stripped from the beginning and end of [s]. *) val strip : ?drop:(char -> bool) -> t -> t (** [map f s] applies [f] to each character in [s], and returns the resulting string. *) val map : t -> f : (char -> char) -> t (** [mapi f s] applies [f] to each character in [s] and its index, and returns the resulting string. *) val mapi : t -> f : (int -> char -> char) -> t (** [foldi] works similarly to [fold], but also pass in index of each character to [f] *) val foldi : t -> init : 'a -> f : (int -> 'a -> char -> 'a) -> 'a (** Like [map], but allows replacement of a single character with zero or two or more characters. *) val concat_map : ?sep:t -> t -> f : (char -> t) -> t (** [filter s ~f:predicate] discards characters not satisfying [predicate] *) val filter : t -> f : (char -> bool) -> t (** [tr target replacement s] replaces every instance of [target] in [s] with [replacement]. *) val tr : target : char -> replacement : char -> t -> t (** [tr_inplace target replacement s] destructively modifies s (in place!) replacing every instance of [target] in [s] with [replacement]. *) val tr_inplace : target : char -> replacement : char -> t -> unit (** [chop_suffix s ~suf] returns a copy [s] without the trailing [suff] @raise Invalid_argument is [suff] is not a suffix of [s] *) val chop_suffix_exn : t -> suffix:t -> t (** [chop_prefix s ~pref] returns a copy [s] without the leading [pref] @raise Invalid_argument is [pref] is not a prefix of [s] *) val chop_prefix_exn : t -> prefix:t -> t val chop_suffix : t -> suffix:t -> t option val chop_prefix : t -> prefix:t -> t option (** [suffix s n] returns the longest suffix of [s] of length less than or equal to [n] *) val suffix : t -> int -> t (** [prefix s n] returns the longest prefix of [s] of length less than or equal to [n] *) val prefix : t -> int -> t (** [drop_suffix s n] drops the longest suffix of [s] of length less than or equal to [n] *) val drop_suffix : t -> int -> t (** [drop_prefix s n] drops the longest prefix of [s] of length less than or equal to [n] *) val drop_prefix : t -> int -> t (** [concat_array sep ar] like {!String.concat}, but operates on arrays *) val concat_array : ?sep : t -> t array -> t (** slightly faster hash function on strings *) external hash : t -> int = "caml_hash_string" "noalloc" (** fast equality function on strings, doesn't use compare_val *) val equal : t -> t -> bool (** [is_empty s] returns [true] iff [s] is empty (i.e. its length is 0). *) val is_empty : t -> bool module Infix : sig val ( ) : t -> int * int -> t end val of_char : char -> t val of_char_list : char list -> t (** Operations for escaping and unescaping strings, with paramaterized escape and escapeworthy characters. Escaping/unescaping using this module is more efficient than using Pcre. Benchmark code can be found in core/benchmarks/string_escaping.ml. *) module Escaping : sig (** [escape_gen_exn escapeworthy_map escape_char] returns a function that will escape a string [s] as follows: if [(c1,c2)] is in [escapeworthy_map], then all occurences of [c1] are replaced by [escape_char] concatenated to [c2]. Raises an exception if [escapeworthy_map] is not one-to-one. If [escape_char] is not in [escapeworthy_map], then it will be escaped to itself.*) val escape_gen_exn : escapeworthy_map:(char * char) list -> escape_char:char -> (string -> string) Staged.t val escape_gen : escapeworthy_map:(char * char) list -> escape_char:char -> (string -> string) Or_error.t (** [escape ~escapeworthy ~escape_char s] is {[ escape_gen_exn ~escapeworthy_map:(List.zip_exn escapeworthy escapeworthy) ~escape_char ]}. Duplicates and [escape_char] will be removed from [escapeworthy]. So, no exception will be raised *) val escape : escapeworthy:char list -> escape_char:char -> (string -> string) Staged.t (** [unescape_gen_exn] is the inverse operation of [escape_gen_exn]. That is, {[ let escape = Staged.unstage (escape_gen_exn ~escapeworthy_map ~escape_char) in let unescape = Staged.unstage (unescape_gen_exn ~escapeworthy_map ~escape_char) in assert (s = unescape (escape s)) ]} always succeed when ~escapeworthy_map is not causing exceptions. *) val unescape_gen_exn : escapeworthy_map:(char * char) list -> escape_char:char -> (string -> string) Staged.t val unescape_gen : escapeworthy_map:(char * char) list -> escape_char:char -> (string -> string) Or_error.t (** [unescape ~escape_char] is defined as [unescape_gen_exn ~map:\[\] ~escape_char] *) val unescape : escape_char:char -> (string -> string) Staged.t (** Any char in an escaped string is either escaping, escaped or literal. For example, for escaped string "0_a0__0" with escape_char as '_', pos 1 and 4 are escaping, 2 and 5 are escaped, and the rest are literal [is_char_escaping s ~escape_char pos] return true if the char at [pos] is escaping, false otherwise. *) val is_char_escaping : string -> escape_char:char -> int -> bool (** [is_char_escaped s ~escape_char pos] return true if the char at [pos] is escaped, false otherwise. *) val is_char_escaped : string -> escape_char:char -> int -> bool (** [is_literal s ~escape_char pos] return true if the char at [pos] is not escaped or escaping. *) val is_char_literal : string -> escape_char:char -> int -> bool (** [index s ~escape_char char] find the first literal (not escaped) instance of char in s starting from 0. *) val index : string -> escape_char:char -> char -> int option val index_exn : string -> escape_char:char -> char -> int (** [rindex s ~escape_char char] find the first literal (not escaped) instance of char in s starting from the end of s and proceeding towards 0. *) val rindex : string -> escape_char:char -> char -> int option val rindex_exn : string -> escape_char:char -> char -> int (** [index_from s ~escape_char pos char] find the first literal (not escaped) instance of char in s starting from pos and proceeding towards the end of s. *) val index_from : string -> escape_char:char -> int -> char -> int option val index_from_exn : string -> escape_char:char -> int -> char -> int (** [rindex_from s ~escape_char pos char] find the first literal (not escaped) instance of char in s starting from pos and towards 0. *) val rindex_from : string -> escape_char:char -> int -> char -> int option val rindex_from_exn : string -> escape_char:char -> int -> char -> int (** [split s ~escape_char ~on] @return a list of substrings of [s] that are separated by literal versions of [on]. Consecutive [on] characters will cause multiple empty strings in the result. Splitting the empty string returns a list of the empty string, not the empty list. e.g. split ~escape_char:'_' ~on:',' "foo,bar_,baz" = ["foo"; "bar_,baz"] *) val split : string -> on:char -> escape_char:char -> string list (** [split_on_chars s ~on] @return a list of all substrings of [s] that are separated by one of the literal chars from [on]. [on] are not grouped. So a grouping of [on] in the source string will produce multiple empty string splits in the result. e.g. split_on_chars ~escape_char:'_' ~on:[',';'|'] "foo_|bar,baz|0" -> ["foo_|bar"; "baz"; "0"] *) val split_on_chars : string -> on:char list -> escape_char:char -> string list (** [lsplit2 s on escape_char] splits s into a pair on the first literal instance of [on] (meaning the first unescaped instance) starting from the left. *) val lsplit2 : string -> on:char -> escape_char:char -> (string * string) option val lsplit2_exn : string -> on:char -> escape_char:char -> (string * string) (** [rsplit2 s on escape_char] splits [s] into a pair on the first literal instance of [on] (meaning the first unescaped instance) starting from the right. *) val rsplit2 : string -> on:char -> escape_char:char -> (string * string) option val rsplit2_exn : string -> on:char -> escape_char:char -> (string * string) end external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" core_kernel-113.00.00/src/core_weak.ml000066400000000000000000000006511256461164500174000ustar00rootroot00000000000000open Std_internal module Weak = Caml.Weak type 'a t = 'a Heap_block.t Weak.t let create ~len = Weak.create len let length t = Weak.length t let set = Weak.set let get = Weak.get let is_some t i = Weak.check t i let is_none t i = not (is_some t i) let to_array t = Array.init (length t) ~f:(fun i -> get t i) let sexp_of_t sexp_of_a t = <:sexp_of< a Heap_block.t option array >> (to_array t) module Make = Weak.Make core_kernel-113.00.00/src/core_weak.mli000066400000000000000000000010231256461164500175430ustar00rootroot00000000000000(** Module for dealing with weak pointers, i.e., pointers that don't prevent garbage collection of what they point to. This module is like the OCaml standard library module of the same name, except that it requires that the values in the weak set are heap blocks. *) type 'a t with sexp_of val create : len:int -> _ t val length : _ t -> int val set : 'a t -> int -> 'a Heap_block.t option -> unit val get : 'a t -> int -> 'a Heap_block.t option val is_some : _ t -> int -> bool val is_none : _ t -> int -> bool core_kernel-113.00.00/src/day_of_week.ml000066400000000000000000000103671256461164500177220ustar00rootroot00000000000000module Array = Core_array module Int = Core_int module List = Core_list module String = Core_string module Hashtbl = Core_hashtbl module Sexp = Core_sexp let failwithf = Core_printf.failwithf module Stable = struct module V1 = struct module T = struct type t = | Sun | Mon | Tue | Wed | Thu | Fri | Sat with bin_io, compare let hash = Hashtbl.hash let to_string t = match t with | Sun -> "SUN" | Mon -> "MON" | Tue -> "TUE" | Wed -> "WED" | Thu -> "THU" | Fri -> "FRI" | Sat -> "SAT" ;; let to_string_long t = match t with | Sun -> "Sunday" | Mon -> "Monday" | Tue -> "Tuesday" | Wed -> "Wednesday" | Thu -> "Thursday" | Fri -> "Friday" | Sat -> "Saturday" ;; let of_string_internal s = match String.uppercase s with | "SUN" | "SUNDAY" -> Sun | "MON" | "MONDAY" -> Mon | "TUE" | "TUESDAY" -> Tue | "WED" | "WEDNESDAY" -> Wed | "THU" | "THURSDAY" -> Thu | "FRI" | "FRIDAY" -> Fri | "SAT" | "SATURDAY" -> Sat | _ -> failwithf "Day_of_week.of_string: %S" s () ;; let of_int_exn i = match i with | 0 -> Sun | 1 -> Mon | 2 -> Tue | 3 -> Wed | 4 -> Thu | 5 -> Fri | 6 -> Sat | _ -> failwithf "Day_of_week.of_int_exn: %d" i () ;; (* Be very generous with of_string. We accept all possible capitalizations and the integer representations as well. *) let of_string s = try of_string_internal s with | _ -> try of_int_exn (Int.of_string s) with | _ -> failwithf "Day_of_week.of_string: %S" s () ;; (* this is in T rather than outside so that the later functor application to build maps uses this sexp representation *) include Sexpable.Of_stringable (struct type nonrec t = t let of_string = of_string let to_string = to_string end) end include T module Unstable = struct include T include (Comparable.Make_binable (T) : Comparable.S_binable with type t := t) include Hashable. Make_binable (T) end include Stable_containers.Comparable.V1.Make (Unstable) include Stable_containers.Hashable.V1.Make (Unstable) end TEST_MODULE "Day_of_week.V1" = Stable_unit_test.Make (struct include V1 let equal a b = (compare a b) = 0 let tests = [ Sun, "SUN", "\000" ; Mon, "MON", "\001" ; Tue, "TUE", "\002" ; Wed, "WED", "\003" ; Thu, "THU", "\004" ; Fri, "FRI", "\005" ; Sat, "SAT", "\006" ] end) end include Stable.V1.Unstable let weekdays = [ Mon; Tue; Wed; Thu; Fri ] let weekends = [ Sat; Sun ] (* written out to save overhead when loading modules. The members of the set and the ordering should never change, so speed wins over something more complex that proves the order = the order in t at runtime *) let all = [ Sun; Mon; Tue; Wed; Thu; Fri; Sat ] TEST = List.is_sorted all ~compare TEST "to_string_long output parses with of_string" = List.for_all all ~f:(fun d -> d = (to_string_long d |> of_string)) let of_int i = try Some (of_int_exn i) with _ -> None let to_int t = match t with | Sun -> 0 | Mon -> 1 | Tue -> 2 | Wed -> 3 | Thu -> 4 | Fri -> 5 | Sat -> 6 ;; let iso_8601_weekday_number t = match t with | Mon -> 1 | Tue -> 2 | Wed -> 3 | Thu -> 4 | Fri -> 5 | Sat -> 6 | Sun -> 7 ;; let num_days_in_week = 7 let shift t i = of_int_exn (Int.( % ) (to_int t + i) num_days_in_week) let num_days ~from ~to_ = let d = to_int to_ - to_int from in if Int.(d < 0) then d + num_days_in_week else d ;; TEST = Int.(num_days ~from:Mon ~to_:Tue = 1);; TEST = Int.(num_days ~from:Tue ~to_:Mon = 6);; TEST "num_days is inverse to shift" = let all_days = [Sun; Mon; Tue; Wed; Thu; Fri; Sat] in List.for_all (List.cartesian_product all_days all_days) ~f:(fun (from, to_) -> let i = num_days ~from ~to_ in Int.(0 <= i && i < num_days_in_week) && shift from i = to_) ;; let is_sun_or_sat t = t = Sun || t = Sat core_kernel-113.00.00/src/day_of_week.mli000066400000000000000000000030111256461164500200570ustar00rootroot00000000000000(** For representing a day of the week. *) type t = | Sun | Mon | Tue | Wed | Thu | Fri | Sat with bin_io, compare, sexp include Comparable.S_binable with type t := t include Hashable. S_binable with type t := t (** [of_string s] accepts three-character abbreviations and full day names with any capitalization, and strings of the integers 0-6. *) include Stringable.S with type t := t (** Capitalized full day names rather than all-caps 3-letter abbreviations *) val to_string_long : t -> string (** These use the same mapping as [Unix.tm_wday]: 0 <-> Sun, ... 6 <-> Sat *) val of_int_exn : int -> t val of_int : int -> t option val to_int : t -> int (** As per ISO 8601, Mon->1, Tue->2, ... Sun->7 *) val iso_8601_weekday_number : t -> int (** This goes forward (or backward) the specified number of weekdays *) val shift : t -> int -> t (** [num_days ~from ~to_] gives the number of days that must elapse from a [from] to get to a [to_], i.e. the smallest non-negative number [i] such that [shift from i = to_]. *) val num_days : from:t -> to_:t -> int val is_sun_or_sat : t -> bool val all : t list val weekdays : t list (** [ Mon; Tue; Wed; Thu; Fri ] *) val weekends : t list (** [ Sat; Sun ] *) module Stable : sig module V1 : sig type nonrec t = t with bin_io, sexp, compare include Stable_containers.Comparable.V1.S with type key := t with type comparator_witness := comparator_witness include Stable_containers.Hashable.V1.S with type key := t end end core_kernel-113.00.00/src/debug.ml000066400000000000000000000024271256461164500165320ustar00rootroot00000000000000open Sexplib open Sexplib.Conv module List = ListLabels module String = StringLabels let eprint message = Printf.eprintf "%s\n%!" message let eprints message a sexp_of_a = eprint (Sexp.to_string_hum (<:sexp_of< string * a >> (message, a))); ;; let eprintf format = Printf.ksprintf eprint format let failwiths = Error.failwiths module Make () = struct let check_invariant = ref true let show_messages = ref true let debug invariant ~module_name = fun name ts arg sexp_of_arg sexp_of_result f -> if !show_messages then eprints (String.concat ~sep:"" [ module_name; "."; name ]) arg sexp_of_arg; if !check_invariant then begin try List.iter ts ~f:invariant with exn -> failwiths "invariant pre-condition failed" (name, exn) <:sexp_of< string * exn >> end; let result_or_exn = Result.try_with f in if !check_invariant then begin try List.iter ts ~f:invariant with exn -> failwiths "invariant post-condition failed" (name, exn) <:sexp_of< string * exn >> end; if !show_messages then eprints (String.concat ~sep:"" [ module_name; "."; name; "-result" ]) result_or_exn <:sexp_of< (result, exn) Result.t >>; Result.ok_exn result_or_exn; ;; end core_kernel-113.00.00/src/debug.mli000066400000000000000000000037761256461164500167130ustar00rootroot00000000000000(** Utilities for printing debug messages. *) open Sexplib (** [eprint message] prints to stderr [message], followed by a newline and flush. This is the same as [prerr_endline]. *) val eprint : string -> unit (** [eprints message a sexp_of_a] prints to stderr [message] and [a] as a sexp, followed by a newline and flush. *) val eprints : string -> 'a -> ('a -> Sexp.t) -> unit (** [eprintf message arg1 ... argn] prints to stderr [message], with sprintf-style format characters instantiated, followed by a newline and flush. *) val eprintf : ('r, unit, string, unit) format4 -> 'r (** [Debug.Make] produces a [debug] function used to wrap a function to display arguments before calling and display results after returning. Intended usage is: {[ module Foo = struct type t = ... let invariant = ... let bar t x y : Result.t = ... end module Foo_debug = struct open Foo include Debug.Make () let debug x = debug invariant ~module_name:"Foo" x let bar t x y = debug "bar" [t] (t, x, y) <:sexp_of< t * X.t * Y.t >> <:sexp_of< Result.t >> (fun () -> bar t x y) end ]} *) module Make () : sig (** Whether the invariants are called on each invocation *) val check_invariant : bool ref (** If true, you get a message on stderr every time [debug] is called *) val show_messages : bool ref (** We avoid labels so that the applications are more concise -- see example above *) val debug : 't Invariant.t -> module_name : string (** appears on messages *) -> (string (** name of function [f], also appears on messages *) -> 't list (** args of type [t], to have invariant checked iff [check_invariant]*) -> 'args (** arguments to function we're debugging *) -> ('args -> Sexp.t) -> ('result -> Sexp.t) -> (unit -> 'result) (** should call [f] with ['args], exn's re-raised *) -> 'result ) end core_kernel-113.00.00/src/decimal.ml000066400000000000000000000013431256461164500170360ustar00rootroot00000000000000open Sexplib exception Decimal_nan_or_inf with sexp type t = float with compare let verify t = match Pervasives.classify_float t with | FP_normal | FP_subnormal | FP_zero -> () | FP_infinite | FP_nan -> raise Decimal_nan_or_inf include Binable.Of_binable (Float) (struct type nonrec t = t let of_binable t = verify t; t let to_binable t = verify t; t end) let sexp_of_t t = Sexp.Atom (Core_printf.sprintf "%.12G" t) let t_of_sexp = function | Sexp.Atom s -> let t = Float.of_string s in begin try verify t with e -> Conv.of_sexp_error (Exn.to_string e) (Sexp.Atom s) end; t | s -> Conv.of_sexp_error "Decimal.t_of_sexp: Expected Atom, found List" s ;; core_kernel-113.00.00/src/decimal.mli000066400000000000000000000011631256461164500172070ustar00rootroot00000000000000(** The [decimal] type alias provides more readable serializations to s-expressions, at the cost of lower precision. For example: {[ # sexp_of_decimal 3.000000000001;; - : Sexp.t = 3 # sexp_of_float 3.000000000001;; - : Sexp.t = 3.0000000000010000889 ]} Also, the decimal sexp-converter will fail when provided with [nan] or [infinity]. {[ # float_of_sexp (Sexp.Atom "nan");; - : float = nan # decimal_of_sexp (Sexp.Atom "nan");; Exception: (Sexplib.Conv.Of_sexp_error (Failure common.ml.Decimal_nan_or_inf) nan). ]} *) type t = float with bin_io, sexp, compare core_kernel-113.00.00/src/deque.ml000066400000000000000000000554351256461164500165560ustar00rootroot00000000000000open Std_internal type 'a t = { (* [arr] is a cyclic buffer *) mutable arr : 'a array; (* [front_index] and [back_index] are the positions in which new elements may be enqueued. This makes the active part of [arr] the range from [front_index+1] to [back_index-1] (modulo the length of [arr] and wrapping around if necessary). Note that this means the active range is maximized when [front_index = back_index], which occurs when there are [Array.length arr - 1] active elements. *) mutable front_index : int; mutable back_index : int; (* apparent_front_index is what is exposed as the front index externally. It has no real relation to the array -- every enqueue to the front decrements it and every dequeue from the front increments it. *) mutable apparent_front_index : int; mutable length : int; (* We keep arr_length here as a speed hack. Calling Array.length on arr is actually meaningfully slower. *) mutable arr_length : int; never_shrink : bool; dummy : 'a; } let create ?initial_length ?never_shrink () = let never_shrink = match never_shrink with | None -> Option.is_some initial_length | Some b -> b in let initial_length = Option.value ~default:7 initial_length in if initial_length < 0 then invalid_argf "passed negative initial_length to Deque.create: %i" initial_length (); (* Make the initial array length be [initial_length + 1] so we can fit [initial_length] elements without growing. We never quite use the whole array. *) let arr_length = initial_length + 1 in let dummy = (Obj.magic () : 'a) in { arr = Array.create ~len:arr_length dummy; front_index = 0; back_index = 1; apparent_front_index = 0; length = 0; arr_length; never_shrink; dummy; } ;; TEST_UNIT = ignore (create ~initial_length:0 () : _ t) let length t = t.length TEST = length (create ()) = 0 let is_empty t = length t = 0 (* We keep track of the length in a mutable field for speed, but this calculation should be correct by construction, and can be used for testing. *) let _invariant_length t = let constructed_length = if t.front_index < t.back_index then t.back_index - t.front_index - 1 else t.back_index - t.front_index - 1 + t.arr_length in assert (length t = constructed_length) ;; let clear t = begin if t.never_shrink then (* clear the array to allow elements to be garbage collected *) Array.replace_all ~f:(fun _ -> t.dummy) t.arr else t.arr <- Array.create ~len:8 t.dummy end; t.front_index <- 0; t.back_index <- 1; t.length <- 0; t.arr_length <- Array.length t.arr; ;; (* The various "when_not_empty" functions return misleading numbers when the dequeue is empty. They are safe to call if it is known that the dequeue is non-empty. *) let apparent_front_index_when_not_empty t = t.apparent_front_index let apparent_back_index_when_not_empty t = t.apparent_front_index + length t - 1 let actual_front_index_when_not_empty t = if t.front_index = t.arr_length - 1 then 0 else t.front_index + 1 ;; let actual_back_index_when_not_empty t = if t.back_index = 0 then t.arr_length - 1 else t.back_index - 1 ;; let checked t f = if is_empty t then None else Some (f t) ;; let apparent_front_index t = checked t apparent_front_index_when_not_empty let apparent_back_index t = checked t apparent_back_index_when_not_empty let foldi' t dir ~init ~f = if is_empty t then init else begin let apparent_front = apparent_front_index_when_not_empty t in let apparent_back = apparent_back_index_when_not_empty t in let actual_front = actual_front_index_when_not_empty t in let actual_back = actual_back_index_when_not_empty t in let rec loop acc ~apparent_i ~real_i ~stop_pos ~step = if real_i = stop_pos then (acc, apparent_i) else loop (f apparent_i acc t.arr.(real_i)) ~apparent_i:(apparent_i + step) ~real_i:(real_i + step) ~stop_pos ~step in (* We want to iterate from actual_front to actual_back (or vice versa), but we may need to wrap around the array to do so. Thus we do the following: 1. If the active range is contiguous (i.e. actual_front <= actual_back), then loop starting at the appropriate end of the active range until we reach the first element outside of it. 2. If it is not contiguous (actual_front > actual_back), then first loop from the appropriate end of the active range to the end of the array. Then, loop from the opposite end of the array to the opposite end of the active range. *) match dir with | `front_to_back -> if actual_front <= actual_back then begin let acc, _ = loop init ~apparent_i:apparent_front ~real_i:actual_front ~stop_pos:(actual_back + 1) ~step:1 in acc end else begin let acc, apparent_i = loop init ~apparent_i:apparent_front ~real_i:actual_front ~stop_pos:t.arr_length ~step:1 in let acc, _ = loop acc ~apparent_i ~real_i:0 ~stop_pos:(actual_back + 1) ~step:1 in acc end | `back_to_front -> if actual_front <= actual_back then begin let acc, _ = loop init ~apparent_i:apparent_back ~real_i:actual_back ~stop_pos:(actual_front - 1) ~step:(-1) in acc end else begin let acc, apparent_i = loop init ~apparent_i:apparent_back ~real_i:actual_back ~stop_pos:(-1) ~step:(-1) in let acc, _ = loop acc ~apparent_i ~real_i:(t.arr_length - 1) ~stop_pos:(actual_front - 1) ~step:(-1) in acc end end ;; let fold' t dir ~init ~f = foldi' t dir ~init ~f:(fun _ acc v -> f acc v) let iteri' t dir ~f = foldi' t dir ~init:() ~f:(fun i () v -> f i v) let iter' t dir ~f = foldi' t dir ~init:() ~f:(fun _ () v -> f v) let fold t ~init ~f = fold' t `front_to_back ~init ~f let foldi t ~init ~f = foldi' t `front_to_back ~init ~f let iteri t ~f = iteri' t `front_to_back ~f let iter t ~f = if not (is_empty t) then begin let actual_front = actual_front_index_when_not_empty t in let actual_back = actual_back_index_when_not_empty t in let rec loop ~real_i ~stop_pos = if real_i < stop_pos then begin f t.arr.(real_i); loop ~real_i:(real_i + 1) ~stop_pos end in if actual_front <= actual_back then loop ~real_i:actual_front ~stop_pos:(actual_back + 1) else begin loop ~real_i:actual_front ~stop_pos:t.arr_length; loop ~real_i:0 ~stop_pos:(actual_back + 1) end end ;; (* We have to be careful here, importing all of Container.Make would change the runtime of some functions ([length] minimally) silently without changing the semantics. We get around that by importing things explicitly. *) module C = Container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter end) let count = C.count let sum = C.sum let exists = C.exists let mem = C.mem let for_all = C.for_all let find_map = C.find_map let find = C.find let to_list = C.to_list let min_elt = C.min_elt let max_elt = C.max_elt let blit new_arr t = assert (not (is_empty t)); let actual_front = actual_front_index_when_not_empty t in let actual_back = actual_back_index_when_not_empty t in let old_arr = t.arr in if actual_front <= actual_back then Array.blit ~src:old_arr ~dst:new_arr ~src_pos:actual_front ~dst_pos:0 ~len:(length t) else begin let break_pos = Array.length old_arr - actual_front in Array.blit ~src:old_arr ~dst:new_arr ~src_pos:actual_front ~dst_pos:0 ~len:break_pos; Array.blit ~src:old_arr ~dst:new_arr ~src_pos:0 ~dst_pos:break_pos ~len:(actual_back + 1); end; (* length depends on t.arr and t.front_index, so this needs to be first *) t.back_index <- length t; t.arr <- new_arr; t.arr_length <- Array.length new_arr; t.front_index <- Array.length new_arr - 1; (* Since t.front_index = Array.length new_arr - 1, this is asserting that t.back_index is a valid index in the array and that the array can support at least one more element -- recall, if t.front_index = t.back_index then the array is full. Note that this is true if and only if Array.length new_arr > length t + 1. *) assert (t.front_index > t.back_index) ;; let maybe_shrink_underlying t = if not t.never_shrink && t.arr_length > 10 && t.arr_length / 3 > length t then begin let new_arr = Array.create ~len:(t.arr_length / 2) t.dummy in blit new_arr t; end ;; let grow_underlying t = let new_arr = Array.create ~len:(t.arr_length * 2) t.dummy in blit new_arr t ;; let enqueue_back t v = if t.front_index = t.back_index then grow_underlying t; t.arr.(t.back_index) <- v; t.back_index <- if t.back_index = t.arr_length - 1 then 0 else t.back_index + 1; t.length <- t.length + 1; ;; let enqueue_front t v = if t.front_index = t.back_index then grow_underlying t; t.arr.(t.front_index) <- v; t.front_index <- if t.front_index = 0 then t.arr_length - 1 else t.front_index - 1; t.apparent_front_index <- t.apparent_front_index - 1; t.length <- t.length + 1; ;; let enqueue t back_or_front v = match back_or_front with | `back -> enqueue_back t v | `front -> enqueue_front t v ;; let peek_front_nonempty t = t.arr.(actual_front_index_when_not_empty t) ;; let peek_front_exn t = if is_empty t then failwith "Deque.peek_front_exn passed an empty queue" else peek_front_nonempty t ;; let peek_front t = if is_empty t then None else Some (peek_front_nonempty t) ;; let peek_back_nonempty t = t.arr.(actual_back_index_when_not_empty t) ;; let peek_back_exn t = if is_empty t then failwith "Deque.peek_back_exn passed an empty queue" else peek_back_nonempty t ;; let peek_back t = if is_empty t then None else Some (peek_back_nonempty t) ;; let peek t back_or_front = match back_or_front with | `back -> peek_back t | `front -> peek_front t ;; let dequeue_front_nonempty t = let i = actual_front_index_when_not_empty t in let res = t.arr.(i) in t.arr.(i) <- t.dummy; t.front_index <- i; t.apparent_front_index <- t.apparent_front_index + 1; t.length <- t.length - 1; maybe_shrink_underlying t; res ;; let dequeue_front_exn t = if is_empty t then failwith "Deque.dequeue_front_exn passed an empty queue" else dequeue_front_nonempty t ;; let dequeue_front t = if is_empty t then None else Some (dequeue_front_nonempty t) ;; let dequeue_back_nonempty t = let i = actual_back_index_when_not_empty t in let res = t.arr.(i) in t.arr.(i) <- t.dummy; t.back_index <- i; t.length <- t.length - 1; maybe_shrink_underlying t; res ;; let dequeue_back_exn t = if is_empty t then failwith "Deque.dequeue_back_exn passed an empty queue" else dequeue_back_nonempty t ;; let dequeue_back t = if is_empty t then None else Some (dequeue_back_nonempty t) ;; let dequeue_exn t back_or_front = match back_or_front with | `front -> dequeue_front_exn t | `back -> dequeue_back_exn t ;; let dequeue t back_or_front = match back_or_front with | `front -> dequeue_front t | `back -> dequeue_back t let drop_gen ?(n=1) ~dequeue t = if n < 0 then invalid_argf "Deque.drop: negative input (%d)" n (); let rec loop n = if n > 0 then match dequeue t with | None -> () | Some _ -> loop (n - 1) in loop n ;; let drop_front ?n t = drop_gen ?n ~dequeue:dequeue_front t let drop_back ?n t = drop_gen ?n ~dequeue:dequeue_back t let drop ?n t back_or_front = match back_or_front with | `back -> drop_back ?n t | `front -> drop_front ?n t ;; let assert_not_empty t name = if is_empty t then failwithf "%s: Deque.t is empty" name () ;; let true_index_exn t i = let i_from_zero = i - t.apparent_front_index in if i_from_zero < 0 || length t <= i_from_zero then begin assert_not_empty t "Deque.true_index_exn"; let apparent_front = apparent_front_index_when_not_empty t in let apparent_back = apparent_back_index_when_not_empty t in invalid_argf "invalid index: %i for array with indices (%i,%i)" i apparent_front apparent_back () end; let true_i = t.front_index + 1 + i_from_zero in if true_i >= t.arr_length then true_i - t.arr_length else true_i ;; let get t i = t.arr.(true_index_exn t i) let get_opt t i = try Some (get t i) with _ -> None let set_exn t i v = t.arr.(true_index_exn t i) <- v let to_array t = match peek_front t with | None -> [| |] | Some front -> let arr = Array.create ~len:(length t) front in ignore (fold t ~init:0 ~f:(fun i v -> arr.(i) <- v; i + 1)); arr ;; let of_array arr = let t = create ~initial_length:(Array.length arr + 1) () in Array.iter arr ~f:(fun v -> enqueue_back t v); t ;; include Bin_prot.Utils.Make_iterable_binable1 (struct type nonrec 'a t = 'a t type 'a el = 'a with bin_io type 'a acc = 'a t let module_name = Some "Core_kernel.Std.Deque" let length = length let iter t ~f = iter t ~f let init n = create ~initial_length:n () let insert t x _ = enqueue_back t x; t let finish = Fn.id end) let t_of_sexp f sexp = of_array (Array.t_of_sexp f sexp) let sexp_of_t f t = Array.sexp_of_t f (to_array t) (* re-expose these here under a different name to avoid internal confusion *) let back_index = apparent_back_index let front_index = apparent_front_index let back_index_exn t = assert_not_empty t "Deque.back_index_exn"; apparent_back_index_when_not_empty t ;; let front_index_exn t = assert_not_empty t "Deque.front_index_exn"; apparent_front_index_when_not_empty t ;; module Binary_searchable = Binary_searchable.Make1 (struct type nonrec 'a t = 'a t let get t i = get t (front_index_exn t + i) let length = length module For_test = struct let of_array = of_array end end) (* The "stable" indices used in this module make the application of the [Binary_searchable] functor awkward. We need to be sure to translate incoming positions from stable space to the expected 0 -> length - 1 space and then we need to translate them back on return. *) let binary_search ?pos ?len t ~compare how v = let pos = match pos with | None -> None | Some pos -> Some (pos - t.apparent_front_index) in match Binary_searchable.binary_search ?pos ?len t ~compare how v with | None -> None | Some untranslated_i -> Some (t.apparent_front_index + untranslated_i) ;; let binary_search_segmented ?pos ?len t ~segment_of how = let pos = match pos with | None -> None | Some pos -> Some (pos - t.apparent_front_index) in match Binary_searchable.binary_search_segmented ?pos ?len t ~segment_of how with | None -> None | Some untranslated_i -> Some (t.apparent_front_index + untranslated_i) ;; TEST_MODULE = struct let binary_search = binary_search ~compare:Int.compare let t = of_array [| 1; 2; 3; 4 |] TEST = binary_search t `First_equal_to 2 = Some 1 TEST = binary_search t `First_equal_to 5 = None TEST = binary_search t `First_equal_to 0 = None TEST = binary_search t ~pos:2 `First_equal_to 2 = None TEST = binary_search t ~pos:2 `First_equal_to 3 = Some 2 let _ = dequeue_front t let _ = dequeue_front t TEST = binary_search t `First_equal_to 2 = None TEST = binary_search t `First_equal_to 3 = Some 2 TEST = binary_search t `First_equal_to 5 = None TEST = binary_search t `First_equal_to 0 = None TEST = binary_search t ~pos:2 `First_equal_to 2 = None TEST = binary_search t ~pos:2 `First_equal_to 3 = Some 2 end TEST_MODULE = struct TEST_UNIT = let q = create () in let bin_alpha _ = assert false in let pos_ref = ref 0 in assert (Int.(=) (length q) 0); let bigstring = Bigstring.create (bin_size_t bin_alpha q) in ignore (bin_write_t bin_alpha bigstring ~pos:0 q); let q' = bin_read_t bin_alpha bigstring ~pos_ref in assert (Int.(=) (length q') 0) module type Deque_intf = sig type 'a t val create : unit -> 'a t val enqueue : 'a t -> [ `back | `front ] -> 'a -> unit val dequeue : 'a t -> [ `back | `front ] -> 'a option val to_array : 'a t -> 'a array val clear : 'a t -> unit val length : 'a t -> int val iter : 'a t -> f:('a -> unit) -> unit val fold' : 'a t -> [`front_to_back | `back_to_front] -> init:'b -> f:('b -> 'a -> 'b) -> 'b end module That_dequeue : Deque_intf = struct type 'a t = 'a Doubly_linked.t let create = Doubly_linked.create let enqueue t back_or_front v = match back_or_front with | `back -> ignore (Doubly_linked.insert_last t v) | `front -> ignore (Doubly_linked.insert_first t v) ;; let dequeue t back_or_front = match back_or_front with | `back -> Doubly_linked.remove_last t | `front -> Doubly_linked.remove_first t ;; let fold' t dir ~init ~f = match dir with | `front_to_back -> Doubly_linked.fold t ~init ~f | `back_to_front -> Doubly_linked.fold_right t ~init ~f:(fun x acc -> f acc x) ;; let to_array = Doubly_linked.to_array let clear = Doubly_linked.clear let iter = Doubly_linked.iter let length = Doubly_linked.length end module This_dequeue : Deque_intf = struct type nonrec 'a t = 'a t let create () = create () let enqueue = enqueue let dequeue = dequeue let to_array = to_array let clear = clear let length = length let iter = iter let fold' = fold' end let enqueue (t_a, t_b) back_or_front v = let start_a = This_dequeue.to_array t_a in let start_b = That_dequeue.to_array t_b in This_dequeue.enqueue t_a back_or_front v; That_dequeue.enqueue t_b back_or_front v; let end_a = This_dequeue.to_array t_a in let end_b = That_dequeue.to_array t_b in if end_a <> end_b then failwithf "enqueue transition failure of: %s -> %s vs. %s -> %s" (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t start_a)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t end_a)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t start_b)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t end_b)) () ;; let dequeue (t_a, t_b) back_or_front = let start_a = This_dequeue.to_array t_a in let start_b = That_dequeue.to_array t_b in let a,b = This_dequeue.dequeue t_a back_or_front, That_dequeue.dequeue t_b back_or_front in let end_a = This_dequeue.to_array t_a in let end_b = That_dequeue.to_array t_b in if a <> b || end_a <> end_b then failwithf "error in dequeue: %s (%s -> %s) <> %s (%s -> %s)" (Option.value ~default:"None" (Option.map a ~f:Int.to_string)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t start_a)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t end_a)) (Option.value ~default:"None" (Option.map b ~f:Int.to_string)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t start_b)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t end_b)) () ;; let clear (t_a, t_b) = This_dequeue.clear t_a; That_dequeue.clear t_b ;; let create () = let t_a = This_dequeue.create () in let t_b = That_dequeue.create () in (t_a, t_b) ;; let this_to_string this_t = Sexp.to_string (<:sexp_of> (This_dequeue.to_array this_t)) ;; let that_to_string that_t = Sexp.to_string (<:sexp_of> (That_dequeue.to_array that_t)) ;; let fold_check (t_a, t_b) dir = let make_list fold t = fold t dir ~init:[] ~f:(fun acc x -> x :: acc) in let this_l = make_list This_dequeue.fold' t_a in let that_l = make_list That_dequeue.fold' t_b in if this_l <> that_l then failwithf "error in fold: %s (from %s) <> %s (from %s)" (Sexp.to_string (<:sexp_of> this_l)) (this_to_string t_a) (Sexp.to_string (<:sexp_of> that_l)) (that_to_string t_b) () ;; let iter_check (t_a, t_b) = let make_rev_list iter t = let r = ref [] in iter t ~f:(fun x -> r := x :: !r); !r in let this_l = make_rev_list This_dequeue.iter t_a in let that_l = make_rev_list That_dequeue.iter t_b in if this_l <> that_l then failwithf "error in iter: %s (from %s) <> %s (from %s)" (Sexp.to_string (<:sexp_of> this_l)) (this_to_string t_a) (Sexp.to_string (<:sexp_of> that_l)) (that_to_string t_b) () ;; let length_check (t_a, t_b) = let this_len = This_dequeue.length t_a in let that_len = That_dequeue.length t_b in if this_len <> that_len then failwithf "error in length: %i (for %s) <> %i (for %s)" this_len (this_to_string t_a) that_len (that_to_string t_b) () ;; let test () = let t = create () in let rec loop ops = if ops = 0 then begin let (t_a, t_b) = t in let arr_a = This_dequeue.to_array t_a in let arr_b = That_dequeue.to_array t_b in if arr_a <> arr_b then failwithf "dequeue final states not equal: %s vs. %s" (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t arr_a)) (Sexp.to_string (Array.sexp_of_t Int.sexp_of_t arr_b)) () end else begin let r = Random.int 110 in begin if r < 20 then enqueue t `front (Random.int 10_000) else if r < 40 then enqueue t `back (Random.int 10_000) else if r < 50 then dequeue t `front else if r < 60 then dequeue t `back else if r < 70 then clear t else if r < 80 then fold_check t `front_to_back else if r < 90 then fold_check t `back_to_front else if r < 100 then iter_check t else length_check t end; loop (ops - 1) end in loop 1_000 ;; TEST_UNIT = test () end BENCH_MODULE "Deque" = struct (* this is the old way we used to implement the option versions of peek and dequeue, which did a failwithf. *) BENCH_FUN "assert_not_empty" = let t = create () in fun () -> try assert_not_empty t "Queue.dequeue_front" with _ -> () BENCH_FUN "dequeue_front empty" = let t = create () in fun () -> ignore (dequeue_front t : _ option) BENCH_FUN "peek_back non-empty" = let t = create () in let () = enqueue_back t 2 in fun () -> ignore (peek_back t : _ option) end core_kernel-113.00.00/src/deque.mli000066400000000000000000000104451256461164500167170ustar00rootroot00000000000000(** A double ended queue that can shrink and expand on both ends. An index is assigned to an element when it enters the queue, and the index of an element is static (i.e. an index refers to a distinct element until that element is removed from the queue, no matter how many intervening push/pop operations occur). One consequence of this is that the minimum index may be < 0. The "front" is the smallest valid index, while the "back" is the largest. All operations are amortized O(1) with a small constant. *) type 'a t with bin_io, sexp include Binary_searchable.S1 with type 'a t := 'a t include Container. S1 with type 'a t := 'a t (** [create ?initial_length ?never_shrink ()] create a new [t]. [initial_length] is the initial length of the dequeue; it will be able to hold [initial_length] elements without resizing. It must be positive. If [never_shrink] is true, the physical array will never shrink; only expand. If [initial_length] is given without [never_shrink] then [never_shrink] is presumed to be [true], otherwise [never_shrink] defaults to [false]. *) val create : ?initial_length:int (** defaults to 7 *) -> ?never_shrink:bool (* see comment above *) -> unit -> _ t (** [front_index t] return the index of the front item in [t]. *) val front_index : _ t -> int option (** [front_index_exn t] throws an exception if [t] is empty, otherwise returns the index of the front item in [t] *) val front_index_exn : _ t -> int (** [back_index t] return the index of the back item in [t]. *) val back_index : _ t -> int option (** [back_index_exn t] throws an exception if [t] is empty, otherwise returns the index of the back item in [t] *) val back_index_exn : _ t -> int (** [get_opt t i] return the element at index [i]. Return [None] if [i] is invalid. *) val get_opt : 'a t -> int -> 'a option (** [get t i] return the element at index [i]. Raise an exception if [i] is invalid. *) val get : 'a t -> int -> 'a (** [peek t back_or_front] return the value at the back or front of the dequeue without removing it. *) val peek : 'a t -> [ `back | `front ] -> 'a option val peek_front : 'a t -> 'a option val peek_front_exn : 'a t -> 'a val peek_back : 'a t -> 'a option val peek_back_exn : 'a t -> 'a (** [set_exn t i v] mutate the element at [i]. *) val set_exn : 'a t -> int -> 'a -> unit (** [iter' t ~f] iter over the elements of [t]. *) val iter' : 'a t -> [ `front_to_back | `back_to_front ] -> f:('a -> unit) -> unit (** [iteri t ~f] iter over the elements of t [`front_to_back] passing in the index. *) val iteri : 'a t -> f : (int -> 'a -> unit) -> unit (** [iteri' t ~f] as [iter], but also passes in the index of the current element. *) val iteri' : 'a t -> [ `front_to_back | `back_to_front ] -> f:(int -> 'a -> unit) -> unit (** [fold' t ~init ~f] fold over the elements of [t] *) val fold' : 'a t -> [ `front_to_back | `back_to_front ] -> init:'b -> f:('b -> 'a -> 'b) -> 'b (** [foldi t ~init ~f] as [fold], but also passes in the index of the current element. *) val foldi : 'a t -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b (** [foldi' t ~init ~f] as [fold'], but also passes in the index of the current element to [f]. *) val foldi' : 'a t -> [ `front_to_back | `back_to_front ] -> init:'b -> f:(int -> 'b -> 'a -> 'b) -> 'b (** [enqueue t back_or_front v] push [v] onto the [back_or_front] of [t]. *) val enqueue : 'a t -> [ `back | `front ] -> 'a -> unit val enqueue_front : 'a t -> 'a -> unit val enqueue_back : 'a t -> 'a -> unit (** [clear t] removes all elements from [t]. *) val clear : _ t -> unit (** [drop ?n t back_or_front] drop [n] elements (default 1) from the [back_or_front] of [t]. If [t] has fewer than [n] elements then it is cleared. *) val drop : ?n:int -> _ t -> [ `back | `front ] -> unit val drop_front : ?n:int -> _ t -> unit val drop_back : ?n:int -> _ t -> unit (** [dequeue t back_or_front] remove and return the [back_or_front] of [t] *) val dequeue : 'a t -> [ `back | `front ] -> 'a option val dequeue_exn : 'a t -> [ `back | `front ] -> 'a val dequeue_front : 'a t -> 'a option val dequeue_front_exn : 'a t -> 'a val dequeue_back : 'a t -> 'a option val dequeue_back_exn : 'a t -> 'a core_kernel-113.00.00/src/dequeue.ml000066400000000000000000000000161256461164500170710ustar00rootroot00000000000000include Deque core_kernel-113.00.00/src/dequeue.mli000066400000000000000000000001461256461164500172460ustar00rootroot00000000000000(** [Dequeue] is deprecated, use [Deque] instead. *) include module type of struct include Deque end core_kernel-113.00.00/src/doubly_linked.ml000066400000000000000000000453771256461164500203030ustar00rootroot00000000000000module List = Core_list (* INVARIANT: This exception is raised if a list is mutated during a pending iteration. This invariant is guaranteed by the Header and Elt modules in conjunction. All downstream code in this module need not be concerned with this invariant. *) exception Attempt_to_mutate_list_during_iteration let phys_equal = (==) module Header : sig type t val create : unit -> t val length : t -> int val equal : t -> t -> bool val incr_length : by:int -> t -> unit val check_no_pending_iterations : t -> unit val with_iteration : t -> (unit -> 'a) -> 'a val merge : t -> t -> [ `Same_already | `Merged ] end = struct type s = { mutable length : int; mutable pending_iterations : int; } type t = s Union_find.t let create () = Union_find.create { length = 1; pending_iterations = 0; } let equal (t1 : t) t2 = Union_find.same_class t1 t2 let length t = (Union_find.get t).length let union_find_get__check_no_pending_iterations t = let s = Union_find.get t in if s.pending_iterations > 0 then raise Attempt_to_mutate_list_during_iteration else s let check_no_pending_iterations t = ignore (union_find_get__check_no_pending_iterations t : s) let incr_length ~by:n t = let s = union_find_get__check_no_pending_iterations t in s.length <- s.length + n let with_iteration t f = let s = Union_find.get t in s.pending_iterations <- s.pending_iterations + 1; let res = Result.try_with f in s.pending_iterations <- s.pending_iterations - 1; match res with | Result.Ok v -> v | Result.Error e -> raise e let merge (t1 : t) t2 = if Union_find.same_class t1 t2 then `Same_already else begin let n1 = (union_find_get__check_no_pending_iterations t1).length in let n2 = (union_find_get__check_no_pending_iterations t2).length in with_iteration t1 (fun () -> with_iteration t2 (fun () -> Union_find.union t1 t2; Union_find.set t1 { length = n1 + n2; pending_iterations = 0; })); `Merged end end module Elt : sig type 'a t with sexp_of val header : 'a t -> Header.t val equal : 'a t -> 'a t -> bool val create : 'a -> 'a t val value : 'a t -> 'a val unlink : 'a t -> unit val split_or_splice_before : 'a t -> 'a t -> unit val split_or_splice_after : 'a t -> 'a t -> unit val insert_after : 'a t -> 'a -> 'a t val insert_before : 'a t -> 'a -> 'a t val unlink_before : 'a t -> 'a t val next : 'a t -> 'a t val prev : 'a t -> 'a t end = struct type 'a t = { value : 'a; mutable prev : 'a t; mutable next : 'a t; mutable header : Header.t; } let equal = phys_equal let next t = t.next let prev t = t.prev let header t = t.header let create_aux v header = let rec t = { value = v; prev = t; next = t; header = header; } in t let is_singleton t = equal t t.prev let sexp_of_t sexp_of_a t = sexp_of_a t.value let create v = create_aux v (Header.create ()) let value t = t.value (* [split_or_splice] is sufficient as the lone primitive for accomplishing all pointer updates on cyclic loops of list nodes. It takes two "gaps" between adjacent linked list nodes. If the gaps point into the same list, the result is that it will be split into two lists afterwards. If the gaps point into different lists, the result is that they will be spliced together into one list afterwards. Before After -----+ +----- -----+ +----- A | <--> | B A | <--- ---> | B -----+ +----- -----+ \ / +----- X -----+ +----- -----+ / \ +----- C | <--> | D C | <--- ---> | D -----+ +----- -----+ +----- *) let unsafe_split_or_splice ~prev1:a ~next1:b ~prev2:c ~next2:d = a.next <- d; d.prev <- a; c.next <- b; b.prev <- c let unsafe_split_or_splice_after t1 t2 = unsafe_split_or_splice ~next1:t1.next ~prev1:t1.next.prev ~next2:t2.next ~prev2:t2.next.prev let unsafe_split_or_splice_before t1 t2 = unsafe_split_or_splice ~prev1:t1.prev ~next1:t1.prev.next ~prev2:t2.prev ~next2:t2.prev.next let check_two_nodes_no_pending_iterations t1 t2 = Header.check_no_pending_iterations t1.header; if not (Header.equal t1.header t2.header) then Header.check_no_pending_iterations t2.header (* We redefine safe versions for export *) let split_or_splice_after t1 t2 = check_two_nodes_no_pending_iterations t1 t2; unsafe_split_or_splice_after t1 t2 let split_or_splice_before t1 t2 = check_two_nodes_no_pending_iterations t1 t2; unsafe_split_or_splice_before t1 t2 let insert_before t v = Header.incr_length t.header ~by:1; let node = create_aux v t.header in unsafe_split_or_splice_before t node; node let insert_after t v = Header.incr_length t.header ~by:1; let node = create_aux v t.header in unsafe_split_or_splice_after t node; node let unlink_before t = let node = t.prev in if is_singleton node then node else begin Header.incr_length t.header ~by:(-1); unsafe_split_or_splice_before t node; node.header <- Header.create (); node end let unlink_after t = let node = t.next in if is_singleton node then node else begin Header.incr_length t.header ~by:(-1); unsafe_split_or_splice_after t node; node.header <- Header.create (); node end let unlink t = ignore (unlink_after t.prev) end type 'a t = 'a Elt.t option ref let invariant t = match !t with | None -> () | Some head -> let header = Elt.header head in let rec loop n elt = let next_elt = Elt.next elt in let prev_elt = Elt.prev elt in assert (Elt.equal elt (Elt.prev next_elt)); assert (Elt.equal elt (Elt.next prev_elt)); assert (Header.equal (Elt.header elt) header); if Elt.equal next_elt head then n else loop (n + 1) next_elt in let len = loop 1 head in assert (len = Header.length header) let create (type a) () : a t = ref None let equal (t : _ t) t' = phys_equal t t' let of_list = function | [] -> create () | x :: xs -> let first = Elt.create x in let _last = List.fold xs ~init:first ~f:Elt.insert_after in ref (Some first) let fold_elt t ~init ~f = match !t with | None -> init | Some first -> Header.with_iteration (Elt.header first) (fun () -> let rec loop acc elt = let acc = f acc elt in let next = Elt.next elt in if phys_equal next first then acc else loop acc next in loop init first) ;; let iter_elt t ~f = fold_elt t ~init:() ~f:(fun () elt -> f elt) TEST_UNIT = List.iter [ []; [ 1 ]; [ 2; 3 ]; ] ~f:(fun l -> let sum = ref 0 in iter_elt (of_list l) ~f:(fun elt -> sum := !sum + Elt.value elt); assert (!sum = List.fold l ~init:0 ~f:(+))) ;; open With_return let find_elt t ~f = with_return (fun r -> fold_elt t ~init:() ~f:(fun () elt -> if f (Elt.value elt) then r.return (Some elt)); None) (* this function is lambda lifted for performance, to make direct recursive calls instead of calls through its closure. It also avoids the initial closure allocation. *) let rec iter_loop first f elt = f (Elt.value elt); let next = Elt.next elt in if not (phys_equal next first) then iter_loop first f next let iter t ~f = match !t with | None -> () | Some first -> Header.with_iteration (Elt.header first) (fun () -> iter_loop first f first) module C = Container.Make (struct type 'a t_ = 'a t type 'a t = 'a t_ let fold t ~init ~f = fold_elt t ~init ~f:(fun acc elt -> f acc (Elt.value elt)) let iter = `Custom iter end) let count = C.count let sum = C.sum let exists = C.exists let find = C.find let find_map = C.find_map let fold = C.fold let for_all = C.for_all let mem = C.mem let to_array = C.to_array let min_elt = C.min_elt let max_elt = C.max_elt let unchecked_iter t ~f = match !t with | None -> () | Some first -> let rec loop t f elt = f (Elt.value elt); let next = Elt.next elt in match !t with (* the first element of the bag may have been changed by [f] *) | None -> () | Some first -> if not (phys_equal first next) then loop t f next in loop t f first let is_empty t = Option.is_none !t (* more efficient than what Container.Make returns *) let fold_right t ~init ~f = match !t with | None -> init | Some first -> Header.with_iteration (Elt.header first) (fun () -> let rec loop acc elt = let prev = Elt.prev elt in let acc = f (Elt.value prev) acc in if phys_equal prev first then acc else loop acc prev in loop init first ) let to_list t = fold_right t ~init:[] ~f:(fun x tl -> x :: tl) let length t = match !t with | None -> 0 | Some first -> Header.length (Elt.header first) let sexp_of_t sexp_of_a t = List.sexp_of_t sexp_of_a (to_list t) let t_of_sexp a_of_sexp s = of_list (List.t_of_sexp a_of_sexp s) let copy t = of_list (to_list t) let clear t = (t := None) exception Transfer_src_and_dst_are_same_list let transfer ~src ~dst = if phys_equal src dst then raise Transfer_src_and_dst_are_same_list; match !src with | None -> () | Some src_head -> match !dst with | None -> dst := Some src_head; clear src | Some dst_head -> match Header.merge (Elt.header src_head) (Elt.header dst_head) with | `Same_already -> raise Transfer_src_and_dst_are_same_list | `Merged -> Elt.split_or_splice_before dst_head src_head; clear src let filter_inplace t ~f = let to_remove = List.rev (fold_elt t ~init:[] ~f:(fun elts elt -> if f (Elt.value elt) then elts else elt :: elts)) in List.iter to_remove ~f:(fun elt -> begin match !t with | None -> () | Some head -> if Elt.equal head elt then begin let next_elt = Elt.next elt in t := if Elt.equal head next_elt then None else Some next_elt end end; Elt.unlink elt) exception Elt_does_not_belong_to_list let first_elt t = !t let last_elt t = Option.map ~f:Elt.prev !t let first t = Option.map ~f:Elt.value (first_elt t) let last t = Option.map ~f:Elt.value (last_elt t) let is_first t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then Elt.equal elt first else raise Elt_does_not_belong_to_list let is_last t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then begin let last = Elt.prev first in Elt.equal elt last end else raise Elt_does_not_belong_to_list let prev t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Elt.equal elt first then None else if Header.equal (Elt.header first) (Elt.header elt) then Some (Elt.prev elt) else raise Elt_does_not_belong_to_list let next t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> let last = Elt.prev first in if Elt.equal elt last then None else if Header.equal (Elt.header first) (Elt.header elt) then Some (Elt.next elt) else raise Elt_does_not_belong_to_list let insert_after t elt v = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then Elt.insert_after elt v else raise Elt_does_not_belong_to_list let insert_before t elt v = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Elt.equal elt first then begin let new_elt = Elt.insert_before first v in t := Some new_elt; new_elt end else if Header.equal (Elt.header first) (Elt.header elt) then Elt.insert_before elt v else raise Elt_does_not_belong_to_list let insert_empty t v = let new_elt = Elt.create v in t := Some new_elt; new_elt let insert_last t v = match !t with | None -> insert_empty t v | Some first -> Elt.insert_before first v let insert_first t v = match !t with | None -> insert_empty t v | Some first -> let new_elt = Elt.insert_before first v in t := Some new_elt; new_elt let remove_last t = match !t with | None -> None | Some first -> let last = Elt.unlink_before first in if Elt.equal first last then t := None; Some (Elt.value last) let remove_first t = match !t with | None -> None | Some first -> let second = Elt.next first in ignore (Elt.unlink first); t := if Elt.equal first second then None else Some second; Some (Elt.value first) let remove t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Elt.equal elt first then ignore (remove_first t) else if Header.equal (Elt.header first) (Elt.header elt) then Elt.unlink elt else raise Elt_does_not_belong_to_list exception Invalid_move__elt_equals_anchor let move_before t elt ~anchor = if Elt.equal anchor elt then raise Invalid_move__elt_equals_anchor; if Header.equal (Elt.header anchor) (Elt.header elt) then match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then begin (* unlink [elt] *) let after_elt = Elt.next elt in Elt.split_or_splice_before elt after_elt; let first = if Elt.equal first elt then begin t := Some after_elt; after_elt end else first in (* splice [elt] in before [anchor] *) Elt.split_or_splice_before anchor elt; if Elt.equal first anchor then t := Some elt; end else raise Elt_does_not_belong_to_list else raise Elt_does_not_belong_to_list let move_to_front t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if not (Elt.equal elt first) then move_before t elt ~anchor:first let move_after t elt ~anchor = if Elt.equal anchor elt then raise Invalid_move__elt_equals_anchor; if Header.equal (Elt.header anchor) (Elt.header elt) then match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> if Header.equal (Elt.header first) (Elt.header elt) then begin (* unlink [elt] *) let after_elt = Elt.next elt in Elt.split_or_splice_before elt after_elt; if Elt.equal first elt then t := Some after_elt; (* splice [elt] in after [anchor] *) Elt.split_or_splice_after anchor elt end else raise Elt_does_not_belong_to_list else raise Elt_does_not_belong_to_list let move_to_back t elt = match !t with | None -> raise Elt_does_not_belong_to_list | Some first -> let last = Elt.prev first in if not (Elt.equal elt last) then move_after t elt ~anchor:last TEST_MODULE "move functions" = struct let n = 5 let test k expected = let t = create () in let a = Array.init n (fun i -> insert_last t i) in k t a; invariant t; assert (length t = n); let observed = to_list t in if observed <> expected then begin let open Sexplib.Conv in Error.failwiths "mismatch" (`Expected expected, `Observed observed) <:sexp_of< [`Expected of int list] * [`Observed of int list] >> end TEST_UNIT = test (fun _ _ -> ()) [0; 1; 2; 3; 4] TEST_UNIT = test (fun t a -> move_to_front t a.(4)) [4; 0; 1; 2; 3] TEST_UNIT = test (fun t a -> move_to_front t a.(3)) [3; 0; 1; 2; 4] TEST_UNIT = test (fun t a -> move_to_front t a.(2)) [2; 0; 1; 3; 4] TEST_UNIT = test (fun t a -> move_to_front t a.(1)) [1; 0; 2; 3; 4] TEST_UNIT = test (fun t a -> move_to_front t a.(0)) [0; 1; 2; 3; 4] TEST_UNIT = test (fun t a -> move_to_back t a.(0)) [1; 2; 3; 4; 0] TEST_UNIT = test (fun t a -> move_to_back t a.(1)) [0; 2; 3; 4; 1] TEST_UNIT = test (fun t a -> move_to_back t a.(2)) [0; 1; 3; 4; 2] TEST_UNIT = test (fun t a -> move_to_back t a.(3)) [0; 1; 2; 4; 3] TEST_UNIT = test (fun t a -> move_to_back t a.(4)) [0; 1; 2; 3; 4] TEST_UNIT = test (fun t a -> move_before t a.(2) ~anchor:a.(1)) [0; 2; 1; 3; 4] TEST_UNIT = test (fun t a -> move_before t a.(2) ~anchor:a.(0)) [2; 0; 1; 3; 4] TEST_UNIT = test (fun t a -> move_before t a.(1) ~anchor:a.(0)) [1; 0; 2; 3; 4] TEST_UNIT = test (fun t a -> move_before t a.(0) ~anchor:a.(2)) [1; 0; 2; 3; 4] TEST_UNIT = test (fun t a -> move_before t a.(0) ~anchor:a.(1)) [0; 1; 2; 3; 4] TEST_UNIT = test (fun t a -> move_before t a.(3) ~anchor:a.(2)) [0; 1; 3; 2; 4] TEST_UNIT = test (fun t a -> move_before t a.(2) ~anchor:a.(3)) [0; 1; 2; 3; 4] TEST_UNIT = test (fun t a -> move_after t a.(1) ~anchor:a.(3)) [0; 2; 3; 1; 4] TEST_UNIT = test (fun t a -> move_after t a.(0) ~anchor:a.(2)) [1; 2; 0; 3; 4] TEST_UNIT = test (fun t a -> move_after t a.(1) ~anchor:a.(4)) [0; 2; 3; 4; 1] TEST_UNIT = test (fun t a -> move_after t a.(3) ~anchor:a.(2)) [0; 1; 2; 3; 4] TEST_UNIT = test (fun t a -> move_after t a.(2) ~anchor:a.(3)) [0; 1; 3; 2; 4] end TEST = let t1 = create () in let t2 = create () in let elt = insert_first t1 15 in try remove t2 elt; false with Elt_does_not_belong_to_list -> true TEST = let t1 = create () in let t2 = create () in let elt = insert_first t1 14 in let _ = insert_first t2 13 in try remove t2 elt; false with Elt_does_not_belong_to_list -> true TEST_MODULE "unchecked_iter" = struct let b = of_list [0; 1; 2; 3; 4] let element b n = Option.value_exn (find_elt b ~f:(fun value -> value = n)) let remove b n = remove b (element b n) let insert_after b n_find n_add = ignore (insert_after b (element b n_find) n_add) let to_list f = let r = ref [] in let b = copy b in unchecked_iter b ~f:(fun n -> r := n :: !r; f b n; ); List.rev !r TEST = to_list (fun _ _ -> ()) = [0; 1; 2; 3; 4] TEST = to_list (fun b x -> if x = 0 then remove b 1) = [0; 2; 3; 4] TEST = to_list (fun b x -> if x = 1 then remove b 0) = [0; 1; 2; 3; 4] TEST = to_list (fun b x -> if x = 2 then remove b 1) = [0; 1; 2; 3; 4] TEST = to_list (fun b x -> if x = 2 then begin remove b 4; remove b 3; end) = [0; 1; 2] TEST = to_list (fun b x -> if x = 2 then insert_after b 1 5) = [0; 1; 2; 3; 4] TEST = to_list (fun b x -> if x = 2 then insert_after b 2 5) = [0; 1; 2; 5; 3; 4] TEST = to_list (fun b x -> if x = 2 then insert_after b 3 5) = [0; 1; 2; 3; 5; 4] end let to_sequence t = to_list t |> Sequence.of_list core_kernel-113.00.00/src/doubly_linked.mli000066400000000000000000000114631256461164500204410ustar00rootroot00000000000000(** doubly-linked lists Compared to other doubly-linked lists, in this one: 1. Calls to modification functions (insert*, move*, ...) detect if the list is being iterated over (iter, fold, ...), and if so raise an exception. For example, a use like the following would raise. {[ iter t ~f:(fun _ -> ... remove t e ...) ]} 2. There is a designated "front" and "back" of each list, rather than viewing each element as an equal in a ring. 3. Elements know which list they're in. Each operation that takes an [Elt.t] also takes a [t], first checks that the [Elt] belongs to the [t], and if not, raises. 4. Related to (3), lists cannot be split, though a sort of splicing is available as [transfer]. In other words, no operation will cause one list to become two. This makes this module unsuitable for maintaining the faces of a planar graph under edge insertion and deletion, for example. 5. Another property permitted by (3) and (4) is that [length] is O(1). *) open Sexplib module Elt : sig type 'a t val value : 'a t -> 'a val equal : 'a t -> 'a t -> bool (** pointer equality *) val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t end type 'a t with sexp include Container.S1 with type 'a t := 'a t val invariant : 'a t -> unit (** creating doubly-linked lists *) val create : unit -> 'a t (** [of_list l] returns a doubly-linked list [t] with the same elements as [l] and in the same order (i.e. the first element of [l] is the first element of [t]). It is always the case that [l = to_list (of_list l)]. *) val of_list : 'a list -> 'a t (** predicates *) val equal : 'a t -> 'a t -> bool (** pointer equality *) val is_first : 'a t -> 'a Elt.t -> bool val is_last : 'a t -> 'a Elt.t -> bool (** constant-time extraction of first and last elements. *) val first_elt : 'a t -> 'a Elt.t option val last_elt : 'a t -> 'a Elt.t option val first : 'a t -> 'a option val last : 'a t -> 'a option (** constant-time retrieval of next or previous element. *) val next : 'a t -> 'a Elt.t -> 'a Elt.t option val prev : 'a t -> 'a Elt.t -> 'a Elt.t option (** constant-time insertion of a new element. *) val insert_before : 'a t -> 'a Elt.t -> 'a -> 'a Elt.t val insert_after : 'a t -> 'a Elt.t -> 'a -> 'a Elt.t val insert_first : 'a t -> 'a -> 'a Elt.t val insert_last : 'a t -> 'a -> 'a Elt.t (** constant-time move of an element from and to positions in the same list. An exception is raised if [elt] is equal to [anchor]. *) val move_to_front : 'a t -> 'a Elt.t -> unit val move_to_back : 'a t -> 'a Elt.t -> unit val move_after : 'a t -> 'a Elt.t -> anchor:'a Elt.t -> unit val move_before : 'a t -> 'a Elt.t -> anchor:'a Elt.t -> unit (** constant-time removal of an element. *) val remove : 'a t -> 'a Elt.t -> unit val remove_first : 'a t -> 'a option val remove_last : 'a t -> 'a option (** [fold_elt t ~init ~f] is the same as fold, except [f] is called with the ['a Elt.t]'s from the list instead of the contained ['a] values. Note that like other iteration functions, it is an error to mutate [t] inside the fold. If you'd like to call [remove] on any of the ['a Elt.t]'s, use [filter_inplace]. *) val fold_elt : 'a t -> init:'b -> f:('b -> 'a Elt.t -> 'b) -> 'b val iter_elt : 'a t -> f:('a Elt.t -> unit) -> unit val fold_right : 'a t -> init:'b -> f:('a -> 'b -> 'b) -> 'b (** [find_elt t ~f] finds the first element in [t] that satisfies [f], by testing each of element of [t] in turn until [f] succeeds. *) val find_elt : 'a t -> f:('a -> bool) -> 'a Elt.t option (** [clear t] removes all elements from the list in constant time. *) val clear : 'a t -> unit val copy : 'a t -> 'a t (** [transfer ~src ~dst] has the same behavior as [iter src ~f:(insert_last dst); clear src] except that it runs in constant time. If [s = to_list src] and [d = to_list dst], then after [transfer ~src ~dst]: [to_list src = []] [to_list dst = d @ s] *) val transfer : src:'a t -> dst:'a t -> unit (** [filter_inplace t ~f] removes all elements of [t] that don't satisfy [f]. *) val filter_inplace : 'a t -> f:('a -> bool) -> unit (** [unchecked_iter t ~f] behaves like [iter t ~f] except that [f] is allowed to modify [t]. Adding or removing elements before the element currently being visited has no effect on the traversal. Elements added after the element currently being visited will be traversed. Elements deleted after the element currently being visited will not be traversed. Deleting the element currently visited is an error that is not detected (presumably leading to an infinite loop) . *) val unchecked_iter : 'a t -> f:('a -> unit) -> unit (* A lazy sequence of values from the doubly linked list. The returned sequence is immune to any subsequent mutation of the list. *) val to_sequence : 'a t -> 'a Sequence.t core_kernel-113.00.00/src/either.ml000066400000000000000000000135611256461164500167250ustar00rootroot00000000000000module Stable = struct module V1 = struct type ('f, 's) t = | First of 'f | Second of 's with bin_io, compare, sexp, typerep let map x ~f1 ~f2 = match x with | First x1 -> First (f1 x1) | Second x2 -> Second (f2 x2) end end include Stable.V1 let swap = function | First x -> Second x | Second x -> First x ;; let is_first = function | First _ -> true | Second _ -> false ;; let is_second = function | First _ -> false | Second _ -> true ;; let value (First x | Second x) = x ;; let value_map t ~first ~second = match t with | First x -> first x | Second x -> second x ;; let iter = value_map ;; let map t ~first ~second = match t with | First x -> First (first x) | Second x -> Second (second x) ;; let first x = First x let second x = Second x ;; let equal eq1 eq2 t1 t2 = match t1, t2 with | First x, First y -> eq1 x y | Second x, Second y -> eq2 x y | First _, Second _ | Second _, First _ -> false ;; let invariant f s = function | First x -> f x | Second y -> s y ;; module Make_focused (M : sig type (+'a, +'b) t val return : 'a -> ('a, _) t val other : 'b -> (_, 'b) t val either : ('a, 'b) t -> return:('a -> 'c) -> other:('b -> 'c) -> 'c val combine : ('a, 'd) t -> ('b, 'd) t -> f:('a -> 'b -> 'c) -> other:('d -> 'd -> 'd) -> ('c, 'd) t end) = struct include M open With_return let map t ~f = either t ~return:(fun x -> return (f x)) ~other include Monad.Make2 (struct type nonrec ('a, 'b) t = ('a, 'b) t let return = return ;; let bind t f = either t ~return:f ~other ;; let map = `Custom map end) module App = Applicative.Make2 (struct type nonrec ('a, 'b) t = ('a, 'b) t let return = return ;; let apply t1 t2 = let return f = either t2 ~return:(fun x -> return (f x)) ~other in either t1 ~return ~other ;; let map = `Custom map end) include App module Args = Applicative.Make_args2 (struct type nonrec ('a, 'b) t = ('a, 'b) t include App end) let combine_all = let rec other_loop f acc = function | [] -> other acc | t :: ts -> either t ~return:(fun _ -> other_loop f acc ts) ~other:(fun o -> other_loop f (f acc o) ts) in let rec return_loop f acc = function | [] -> return (List.rev acc) | t :: ts -> either t ~return:(fun x -> return_loop f (x :: acc) ts) ~other:(fun o -> other_loop f o ts) in fun ts ~f -> return_loop f [] ts ;; let combine_all_unit = let rec other_loop f acc = function | [] -> other acc | t :: ts -> either t ~return:(fun () -> other_loop f acc ts) ~other:(fun o -> other_loop f (f acc o) ts) in let rec return_loop f = function | [] -> return () | t :: ts -> either t ~return:(fun () -> return_loop f ts) ~other:(fun o -> other_loop f o ts) in fun ts ~f -> return_loop f ts ;; let iter t ~f = either t ~return:f ~other:(fun _ -> ()) ;; let to_option t = either t ~return:Option.some ~other:(fun _ -> None) ;; let fold t ~init ~f = either t ~return:(fun x -> f init x) ~other:(fun _ -> init) ;; let value t ~default = either t ~return:(fun x -> x) ~other:(fun _ -> default) ;; let count t ~f = fold t ~init:0 ~f:(fun n a -> if f a then n + 1 else n) ;; let sum (type a) (module M : Commutative_group.S with type t = a) t ~f = fold t ~init:M.zero ~f:(fun n a -> M.(+) n (f a)) ;; let length c = fold c ~init:0 ~f:(fun acc _ -> acc + 1) ;; let is_empty c = with_return (fun r -> iter c ~f:(fun _ -> r.return false); true) ;; let exists c ~f = with_return (fun r -> iter c ~f:(fun x -> if f x then r.return true); false) ;; let mem ?(equal = (=)) t a = exists t ~f:(equal a) ;; let for_all c ~f = with_return (fun r -> iter c ~f:(fun x -> if not (f x) then r.return false); true) ;; let find_map t ~f = with_return (fun r -> iter t ~f:(fun x -> match f x with None -> () | Some _ as res -> r.return res); None) ;; let find c ~f = with_return (fun r -> iter c ~f:(fun x -> if f x then r.return (Some x)); None) ;; let to_list c = List.rev (fold c ~init:[] ~f:(fun acc x -> x :: acc)) ;; let to_array c = Array.of_list (to_list c) ;; let min_elt t ~cmp = fold t ~init:None ~f:(fun acc elt -> match acc with | None -> Some elt | Some min -> if cmp min elt > 0 then Some elt else acc) ;; let max_elt t ~cmp = fold t ~init:None ~f:(fun acc elt -> match acc with | None -> Some elt | Some max -> if cmp max elt < 0 then Some elt else acc) ;; let with_return f = with_return (fun ret -> other (f (With_return.prepend ret ~f:return))) ;; end module First = Make_focused (struct type nonrec ('a, 'b) t = ('a, 'b) t let return = first let other = second ;; let either t ~return ~other = match t with | First x -> return x | Second y -> other y ;; let combine t1 t2 ~f ~other = match t1, t2 with | First x, First y -> First (f x y) | Second x, Second y -> Second (other x y) | Second x, _ | _, Second x -> Second x end) module Second = Make_focused (struct type nonrec ('a, 'b) t = ('b, 'a) t let return = second let other = first ;; let either t ~return ~other = match t with | Second y -> return y | First x -> other x ;; let combine t1 t2 ~f ~other = match t1, t2 with | Second x, Second y -> Second (f x y) | First x, First y -> First (other x y) | First x, _ | _, First x -> First x end) module Export = struct type ('f, 's) _either = ('f, 's) t = First of 'f | Second of 's end core_kernel-113.00.00/src/either.mli000066400000000000000000000000261256461164500170660ustar00rootroot00000000000000include Either_intf.S core_kernel-113.00.00/src/either_intf.ml000066400000000000000000000046371256461164500177510ustar00rootroot00000000000000(** Many functions in [Either] focus on just one constructor. The [Focused] signature abstracts over which constructor is the focus. To use these functions, use the [First] or [Second] modules in [S]. *) module type Focused = sig type (+'focus, +'other) t include Monad.S2 with type ('a, 'b) t := ('a, 'b) t include Applicative.S2 with type ('a, 'b) t := ('a, 'b) t include Container.S1_phantom with type ('a, 'b) t := ('a, 'b) t module Args : Applicative.Args2 with type ('a, 'e) arg := ('a, 'e) t val value : ('a, _) t -> default:'a -> 'a val to_option : ('a, _) t -> 'a option val with_return : ('a With_return.return -> 'b) -> ('a, 'b) t val combine : ('a, 'd) t -> ('b, 'd) t -> f:('a -> 'b -> 'c) -> other:('d -> 'd -> 'd) -> ('c, 'd) t val combine_all : ('a, 'b) t list -> f:('b -> 'b -> 'b) -> ('a list, 'b) t val combine_all_unit : (unit, 'b) t list -> f:('b -> 'b -> 'b) -> (unit, 'b) t end module type S = sig (** This type represents values with two possibilities. [Either] can be seen as a generic sum type, the dual of [Tuple]. [First] is neither more important nor less important than [Second]. *) type ('f, 's) t = | First of 'f | Second of 's with bin_io, compare, sexp, typerep include Invariant.S2 with type ('a, 'b) t := ('a, 'b) t val swap : ('f, 's) t -> ('s, 'f) t val value : ('a, 'a) t -> 'a val iter : ('a, 'b) t -> first:('a -> unit) -> second:('b -> unit) -> unit val value_map : ('a, 'b) t -> first:('a -> 'c) -> second:('b -> 'c) -> 'c val map : ('a, 'b) t -> first:('a -> 'c) -> second:('b -> 'd) -> ('c, 'd) t val equal : ('f -> 'f -> bool) -> ('s -> 's -> bool) -> ('f, 's) t -> ('f, 's) t -> bool module First : Focused with type ('a, 'b) t = ('a, 'b) t module Second : Focused with type ('a, 'b) t = ('b, 'a) t val is_first : (_, _) t -> bool val is_second : (_, _) t -> bool (** [first] and [second] are [First.return] and [Second.return]. *) val first : 'f -> ('f, _) t val second : 's -> (_, 's) t module Export : sig type ('f, 's) _either = ('f, 's) t = First of 'f | Second of 's end module Stable : sig module V1 : sig type nonrec ('f, 's) t = ('f, 's) t = First of 'f | Second of 's include Stable_module_types.S2 with type ('f, 's) t := ('f, 's) t end end end core_kernel-113.00.00/src/equal.ml000066400000000000000000000014231256461164500165460ustar00rootroot00000000000000(** This module defines signatures that are to be included in other signatures to ensure a consistent interface to [equal] functions. There is a signature ([S], [S1], [S2], [S3]) for each arity of type. Usage looks like: {[ type t include Equal.S with type t := t ]} or {[ type 'a t include Equal.S1 with type 'a t := 'a t ]} *) type 'a t = 'a -> 'a -> bool type 'a equal = 'a t module type S = sig type t val equal : t equal end module type S1 = sig type 'a t val equal : 'a equal -> 'a t equal end module type S2 = sig type ('a, 'b) t val equal : 'a equal -> 'b equal -> ('a, 'b) t equal end module type S3 = sig type ('a, 'b, 'c) t val equal : 'a equal -> 'b equal -> 'c equal -> ('a, 'b, 'c) t equal end core_kernel-113.00.00/src/error.ml000066400000000000000000000010271256461164500165700ustar00rootroot00000000000000(* This module is trying to minimize dependencies on modules in Core, so as to allow [Error] and [Or_error] to be used in various places. Please avoid adding new dependencies. *) include Info let raise t = raise (to_exn t) let to_info t = t let of_info t = t let failwiths ?strict ?here message a sexp_of_a = raise (create ?strict ?here message a sexp_of_a) ;; let failwithp ?strict here message a sexp_of_a = raise (create ?strict ~here message a sexp_of_a) ;; let () = Pretty_printer.register "Core_kernel.Error.pp" core_kernel-113.00.00/src/error.mli000066400000000000000000000027271256461164500167510ustar00rootroot00000000000000open Sexplib include module type of Info (** Note that the exception raised by this function maintains a reference to the [t] passed in. *) val raise : t -> _ val to_info : t -> Info.t val of_info : Info.t -> t (** {[ failwiths ?strict ?here message a sexp_of_a = Error.raise (Error.create ?strict ?here s a sexp_of_a) ]} As with [Error.create], [sexp_of_a a] is lazily computed, when the error is converted to a sexp. So, if [a] is mutated in the time between the call to [failwiths] and the sexp conversion, those mutations will be reflected in the error message. Use [~strict:()] to force [sexp_of_a a] to be computed immediately. The [pa_fail] preprocessor replaces [failwiths] with [failwiths ?here:_here_] so that one does not need to (and cannot) supply [_here_]. [pa_fail] does not add [?here:_here_] to [Error.failwiths]. In this signature we write [?here:Lexing.position] rather than [?here:Source_code_position.t] to avoid a circular dependency. [failwithp here] is like [failwiths ~here], except that you can provide a source position yourself (which is only interesting if you don't provide [_here_]). *) val failwiths : ?strict : unit -> ?here : Lexing.position -> string -> 'a -> ('a -> Sexp.t) -> _ val failwithp : ?strict : unit -> Lexing.position -> string -> 'a -> ('a -> Sexp.t) -> _ (** [Error.t] is NOT wire-compatible with [Error.Stable.V1.t]. See info.mli for details. *) core_kernel-113.00.00/src/exn.ml000066400000000000000000000115641256461164500162400ustar00rootroot00000000000000module Sexp = Sexplib.Sexp module Conv = Sexplib.Conv open Sexplib.Std let sexp_of_exn = Conv.sexp_of_exn let sexp_of_exn_opt = Conv.sexp_of_exn_opt type t = exn with sexp_of exception Finally of t * t with sexp exception Reraised of string * t with sexp let reraise exc str = raise (Reraised (str, exc)) let reraisef exc format = Printf.ksprintf (fun str () -> reraise exc str) format let () = StdLabels.List.iter ~f:(fun (exc, handler) -> Conv.Exn_converter.add_auto ~finalise:false exc handler) [ ( Bin_prot.Common.Read_error (Bin_prot.Common.ReadError.Neg_int8, 0), (function | Bin_prot.Common.Read_error (err, pos) -> let str_err = Bin_prot.Common.ReadError.to_string err in Sexp.List [ Sexp.Atom "Bin_prot.Common.Read_error"; Sexp.Atom str_err; Conv.sexp_of_int pos; ] | _ -> assert false) ); ] let to_string exc = Sexp.to_string_hum ~indent:2 (sexp_of_exn exc) let to_string_mach exc = Sexp.to_string_mach (sexp_of_exn exc) let sexp_of_t = sexp_of_exn let protectx ~f x ~(finally : _ -> unit) = let res = try f x with exn -> (try finally x with final_exn -> raise (Finally (exn, final_exn))); raise exn in finally x; res ;; let protect ~f ~finally = protectx ~f () ~finally let does_raise (type a) (f : unit -> a) = try ignore (f () : a); false with _ -> true ;; TEST = not (does_raise Fn.ignore) TEST = does_raise (fun () -> failwith "foo") include Pretty_printer.Register_pp (struct type t = exn let pp ppf t = match sexp_of_exn_opt t with | Some sexp -> Sexp.pp_hum ppf sexp | None -> Format.pp_print_string ppf (Printexc.to_string t) ;; let module_name = "Core_kernel.Std.Exn" end) let backtrace = Printexc.get_backtrace let print_with_backtrace exc raw_backtrace = Format.eprintf "@[<2>Uncaught exception:@\n@\n@[%a@]@]@\n@." pp exc; if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr raw_backtrace; flush stderr; ;; let () = Printexc.set_uncaught_exception_handler print_with_backtrace let handle_uncaught_aux ~exit f = try f () with exc -> begin try print_with_backtrace exc (Printexc.get_raw_backtrace ()) with _ -> try Printf.eprintf "Exn.handle_uncaught could not print; exiting anyway\n%!"; with _ -> () end; exit 1 ;; let handle_uncaught_and_exit f = handle_uncaught_aux f ~exit let handle_uncaught ~exit:must_exit f = handle_uncaught_aux f ~exit:(if must_exit then exit else ignore) let reraise_uncaught str func = try func () with | exn -> raise (Reraised (str, exn)) let () = Printexc.register_printer (fun exc -> match sexp_of_exn_opt exc with | None -> None | Some sexp -> Some (Sexp.to_string_hum ~indent:2 sexp)) external clear_backtrace : unit -> unit = "clear_caml_backtrace_pos" "noalloc" let raise_without_backtrace e = (* We clear the backtrace to reduce confusion, so that people don't think whatever is stored corresponds to this raise. *) clear_backtrace (); raise_notrace e ;; TEST_MODULE = struct exception Test_exception let with_backtraces_enabled f = let saved = Printexc.backtrace_status () in Printexc.record_backtrace true; protect ~f ~finally:(fun () -> Printexc.record_backtrace saved) ;; TEST_UNIT "clear_backtrace" = with_backtraces_enabled (fun () -> begin try raise Test_exception with _ -> () end; assert (backtrace () <> ""); clear_backtrace (); assert (backtrace () = "")); ;; let check_if_empty_backtrace raise_f = with_backtraces_enabled (fun () -> clear_backtrace (); (* The call to [raise] installs a new saved backtrace. Then, the call to [raise_f], if it's [raise], should save a new, different backtrace, while if it's [raise_without_backtrace], should clear the backtrace and then not install a new one when raising. *) let old_backtrace = try raise Not_found with Not_found -> backtrace () in assert (old_backtrace <> ""); let new_backtrace = try raise_f Test_exception with Test_exception -> backtrace () in assert (new_backtrace <> old_backtrace); new_backtrace = ""); ;; TEST = not (check_if_empty_backtrace raise) TEST = check_if_empty_backtrace raise_without_backtrace end BENCH_MODULE "raise" = struct exception Test_exception let nested_raise raise_f depth = let rec loop d = if d = 0 then raise_f Test_exception else loop (d - 1) + 1 in (fun () -> try ignore (loop depth : int) with | Test_exception -> ()) ;; let depths = [ 0; 10; 100; 1000; 10_000 ] BENCH_INDEXED "raise" depth depths = nested_raise raise depth BENCH_INDEXED "raise_without_backtrace" depth depths = nested_raise raise_without_backtrace depth ;; end core_kernel-113.00.00/src/exn.mli000066400000000000000000000046561256461164500164150ustar00rootroot00000000000000open Never_returns (** [sexp_of_t] uses a global table of sexp converters. To register a converter for a new exception, add "with sexp" to its definition. If no suitable converter is found, the standard converter in [Printexc] will be used to generate an atomic S-expression. *) type t = exn with sexp_of include Pretty_printer.S with type t := t (** Raised when finalization after an exception failed, too. The first exception argument is the one raised by the initial function, the second exception the one raised by the finalizer. *) exception Finally of t * t exception Reraised of string * t (** Same as [raise], except that the backtrace is not recorded. *) val raise_without_backtrace : t -> _ val reraise : t -> string -> _ (** Types with [format4] are hard to read, so here's an example. {[ let foobar str = try ... with exn -> Exn.reraisef exn "Foobar is buggy on: %s" str () ]} *) val reraisef : t -> ('a, unit, string, unit -> _) format4 -> 'a val to_string : t -> string (* human-readable, multi-lines *) val to_string_mach : t -> string (* machine format, single-line *) (** Executes [f] and afterwards executes [finally], whether [f] throws an exception or not. *) val protectx : f:('a -> 'b) -> 'a -> finally:('a -> unit) -> 'b val protect : f:(unit -> 'a) -> finally:(unit -> unit) -> 'a (** [handle_uncaught ~exit f] catches an exception escaping [f] and prints an error message to stderr. Exits with return code 1 if [exit] is [true]. Otherwise returns unit. *) val handle_uncaught : exit:bool -> (unit -> unit) -> unit (** [handle_uncaught_and_exit f] returns [f ()], unless that raises, in which case it prints the exception and exits nonzero. *) val handle_uncaught_and_exit : (unit -> 'a) -> 'a (** Traces exceptions passing through. Useful because in practice backtraces still don't seem to work. Example: {[ let rogue_function () = if Random.bool () then failwith "foo" else 3 let traced_function () = Exn.reraise_uncaught "rogue_function" rogue_function traced_function ();; ]} {v : Program died with Reraised("rogue_function", Failure "foo") v} *) val reraise_uncaught : string -> (unit -> 'a) -> 'a (** [does_raise f] returns [true] iff [f ()] raises, which is often useful in unit tests. *) val does_raise : (unit -> _) -> bool (** The same as {!Printexc.get_backtrace} *) val backtrace : unit -> string core_kernel-113.00.00/src/exn_stubs.c000066400000000000000000000002721256461164500172640ustar00rootroot00000000000000#include extern int caml_backtrace_pos; CAMLprim value clear_caml_backtrace_pos (value __attribute__((unused)) unit) { caml_backtrace_pos = 0; return Val_unit; } core_kernel-113.00.00/src/fdeque.ml000066400000000000000000000215161256461164500167150ustar00rootroot00000000000000(** Simple implementation of a polymorphic functional double-ended queue. *) (** Invariants: - queue.length = List.length queue.front + List.length queue.back - if queue has >= 2 elements, neither front nor back are empty *) open Std_internal exception Empty with sexp type 'a t = { front : 'a list; back : 'a list; length : int } let length t = t.length let is_empty t = t.length = 0 let invariant f t = let n_front = List.length t.front in let n_back = List.length t.back in assert (t.length = n_front + n_back); assert (t.length < 2 || (n_front <> 0 && n_back <> 0)); List.iter t.front ~f; List.iter t.back ~f ;; let make ~length ~front ~back = match front, back with | [], [] | [_], [] | [], [_] | _::_, _::_ -> { front ; back ; length } | [], _ :: _ :: _ -> let back, rev_front = List.split_n back (length/2) in { front = List.rev rev_front ; back ; length } | _ :: _ :: _, [] -> let front, rev_back = List.split_n front (length/2) in { front ; back = List.rev rev_back ; length } ;; let empty = { front = [] ; back = [] ; length = 0 } let enqueue_front t x = make ~length:(t.length + 1) ~front:(x :: t.front) ~back:t.back ;; let enqueue_back t x = make ~length:(t.length + 1) ~back:(x :: t.back) ~front:t.front ;; let raise_front_invariant () = raise (Bug "Fdeque: |front| = 0, |back| >= 2") let raise_back_invariant () = raise (Bug "Fdeque: |back| = 0, |front| >= 2") let peek_front_exn t = match t.front with | x :: _ -> x | [] -> match t.back with | [] -> raise Empty | [x] -> x | _ :: _ :: _ -> raise_front_invariant () ;; let peek_back_exn t = match t.back with | x :: _ -> x | [] -> match t.front with | [] -> raise Empty | [x] -> x | _ :: _ :: _ -> raise_back_invariant () ;; let drop_front_exn t = match t.front with | _ :: xs -> make ~length:(t.length - 1) ~front:xs ~back:t.back | [] -> match t.back with | [] -> raise Empty | [_] -> empty | _ :: _ :: _ -> raise_front_invariant () ;; let drop_back_exn t = match t.back with | _ :: xs -> make ~length:(t.length - 1) ~back:xs ~front:t.front | [] -> match t.front with | [] -> raise Empty | [_] -> empty | _ :: _ :: _ -> raise_front_invariant () ;; let dequeue_front_exn t = peek_front_exn t, drop_front_exn t let dequeue_back_exn t = peek_back_exn t, drop_back_exn t let optional f t = match f t with | x -> Some x | exception Empty -> None ;; let peek_front t = optional peek_front_exn t let peek_back t = optional peek_back_exn t let drop_front t = optional drop_front_exn t let drop_back t = optional drop_back_exn t let dequeue_front t = optional dequeue_front_exn t let dequeue_back t = optional dequeue_back_exn t let enqueue t side x = match side with | `front -> enqueue_front t x | `back -> enqueue_back t x ;; let peek t side = match side with | `front -> peek_front t | `back -> peek_back t ;; let peek_exn t side = match side with | `front -> peek_front_exn t | `back -> peek_back_exn t ;; let drop t side = match side with | `front -> drop_front t | `back -> drop_back t ;; let drop_exn t side = match side with | `front -> drop_front_exn t | `back -> drop_back_exn t ;; let dequeue t side = match side with | `front -> dequeue_front t | `back -> dequeue_back t ;; let dequeue_exn t side = match side with | `front -> dequeue_front_exn t | `back -> dequeue_back_exn t ;; let rev t = { t with front = t.back ; back = t.front } BENCH_MODULE "accessors" = struct module Make (M : sig val t : int t end) = struct BENCH "rev" = rev M.t BENCH "enqueue_front" = enqueue_front M.t 0 BENCH "enqueue_back" = enqueue_back M.t 0 BENCH "peek_front" = peek_front M.t BENCH "peek_back" = peek_back M.t BENCH "peek_front_exn" = peek_front_exn M.t BENCH "peek_back_exn" = peek_back_exn M.t BENCH "drop_front" = drop_front M.t BENCH "drop_back" = drop_back M.t BENCH "drop_front_exn" = drop_front_exn M.t BENCH "drop_back_exn" = drop_back_exn M.t BENCH "dequeue_front" = dequeue_front M.t BENCH "dequeue_back" = dequeue_back M.t BENCH "dequeue_front_exn" = dequeue_front_exn M.t BENCH "dequeue_back_exn" = dequeue_back_exn M.t end let build front back = let length = List.length front + List.length back in let t = { length ; front ; back } in invariant ignore t; t ;; let list n = List.init n ~f:Int.succ BENCH_MODULE "balanced" = Make (struct let t = build (list 50) (list 50) end) BENCH_MODULE "short back" = Make (struct let t = build (list 99) (list 1) end) BENCH_MODULE "short front" = Make (struct let t = build (list 1) (list 99) end) end module Arbitrary_order = struct let is_empty = is_empty let length = length let to_list t = List.rev_append t.front t.back let to_array t = Array.of_list (to_list t) let sum (type a) (module M : Commutative_group.S with type t = a) t ~f = let open M in List.sum (module M) t.front ~f + List.sum (module M) t.back ~f ;; let count t ~f = List.count t.front ~f + List.count t.back ~f let for_all t ~f = List.for_all t.front ~f && List.for_all t.back ~f let exists t ~f = List.exists t.front ~f || List.exists t.back ~f let mem ?equal t x = List.mem ?equal t.front x || List.mem ?equal t.back x let iter t ~f = List.iter t.front ~f ; List.iter t.back ~f ;; let fold t ~init ~f = List.fold t.front ~init ~f |> fun init -> List.fold t.back ~init ~f ;; let find t ~f = match List.find t.front ~f with | None -> List.find t.back ~f | some -> some ;; let find_map t ~f = match List.find_map t.front ~f with | None -> List.find_map t.back ~f | some -> some ;; let max_elt t ~cmp = match List.max_elt t.front ~cmp, List.max_elt t.back ~cmp with | None, opt | opt, None -> opt | (Some x as some_x), (Some y as some_y) -> if cmp x y >= 0 then some_x else some_y ;; let min_elt t ~cmp = match List.min_elt t.front ~cmp, List.min_elt t.back ~cmp with | None, opt | opt, None -> opt | (Some x as some_x), (Some y as some_y) -> if cmp x y <= 0 then some_x else some_y ;; end module Make_container(F : sig val to_list : 'a t -> 'a list end) = struct let to_list = F.to_list let is_empty = is_empty let length = length let mem ?equal t x = List.mem ?equal (to_list t) x let iter t ~f = List.iter (to_list t) ~f let fold t ~init ~f = List.fold (to_list t) ~init ~f let exists t ~f = List.exists (to_list t) ~f let for_all t ~f = List.for_all (to_list t) ~f let count t ~f = List.count (to_list t) ~f let sum m t ~f = List.sum m (to_list t) ~f let find t ~f = List.find (to_list t) ~f let find_map t ~f = List.find_map (to_list t) ~f let to_array t = List.to_array (to_list t) let min_elt t ~cmp = List.min_elt (to_list t) ~cmp let max_elt t ~cmp = List.max_elt (to_list t) ~cmp end module Front_to_back = struct let of_list list = make ~length:(List.length list) ~front:list ~back:[] let to_list t = t.front @ List.rev t.back TEST = List.equal [1;2;3] (to_list (of_list [1;2;3])) ~equal:Int.equal include Make_container(struct let to_list = to_list end) end module Back_to_front = struct let to_list t = t.back @ List.rev t.front let of_list list = make ~length:(List.length list) ~back:list ~front:[] TEST = List.equal [1;2;3] (to_list (of_list [1;2;3])) ~equal:Int.equal include Make_container(struct let to_list = to_list end) end include Front_to_back let singleton x = of_list [x] let compare cmp t1 t2 = List.compare cmp (to_list t1) (to_list t2) module Stable = struct module V1 = struct type nonrec 'a t = 'a t let compare = compare let sexp_of_t sexp_of_elt t = Sexplib.Conv.sexp_of_list sexp_of_elt (to_list t) let t_of_sexp elt_of_sexp sexp = of_list (Sexplib.Conv.list_of_sexp elt_of_sexp sexp) TEST = List.equal [1;2;3] (to_list (t_of_sexp Int.t_of_sexp (sexp_of_t Int.sexp_of_t (of_list [1;2;3])))) ~equal:Int.equal ;; include Bin_prot.Utils.Make_iterable_binable1 (struct type nonrec 'a t = 'a t type 'a acc = 'a t type 'a el = 'a with bin_io let module_name = Some "Core.Fdeque" let length = length let iter t ~f = List.iter (to_list t) ~f let init _ = empty let insert t x n = assert (n = length t); enqueue_back t x let finish t = t end) end end include (Stable.V1 : module type of Stable.V1 with type 'a t := 'a t) core_kernel-113.00.00/src/fdeque.mli000066400000000000000000000070571256461164500170720ustar00rootroot00000000000000(** A simple polymorphic functional double-ended queue. Use this if you need a queue-like data structure that provides enqueue and dequeue accessors on both ends. For strictly first-in, first-out access, see [Fqueue]. Amortized running times assume that enqueue/dequeue are used sequentially, threading the changing deque through the calls. *) type 'a t with bin_io, compare, sexp (** [Container] operations traverse deque elements front-to-back, like [Front_to_back] below. If you need faster traversal and don't care about the order, use [Arbitrary_order] below. [is_empty] and [length] have worst-case complexity O(1). *) include Container.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t (** Traverse deque elements in arbitrary order. *) module Arbitrary_order : sig include Container.S1 with type 'a t := 'a t end (** Traverse deque elements front-to-back. Incurs up to O(n) additional time and space cost over [Arbitrary_order]. *) module Front_to_back : sig val of_list : 'a list -> 'a t include Container.S1 with type 'a t := 'a t end (** Traverse deque elements back-to-front. Incurs up to O(n) additional time and space cost over [Arbitrary_order]. *) module Back_to_front : sig val of_list : 'a list -> 'a t include Container.S1 with type 'a t := 'a t end (** The empty deque. *) val empty : _ t (** A one-element deque. *) val singleton : 'a -> 'a t (** [of_list] returns a deque with elements in the same front-to-back order as the list. *) val of_list : 'a list -> 'a t (** [rev t] returns [t], reversed. Complexity: worst-case O(1) *) val rev : 'a t -> 'a t (** [enqueue t side x] produces [t] updated with [x] added to its [side]. Complexity: worst-case O(1). *) val enqueue : 'a t -> [ `back | `front ] -> 'a -> 'a t val enqueue_front : 'a t -> 'a -> 'a t val enqueue_back : 'a t -> 'a -> 'a t (** [peek t side] produces [Some] of the element at the [side] of [t], or [None] if [t] is empty. Complexity: worst-case O(1). *) val peek : 'a t -> [ `back | `front ] -> 'a option val peek_exn : 'a t -> [ `back | `front ] -> 'a val peek_front : 'a t -> 'a option val peek_front_exn : 'a t -> 'a val peek_back : 'a t -> 'a option val peek_back_exn : 'a t -> 'a (** [drop t side] produces [Some] of [t] with the element at its [side] removed, or [None] if [t] is empty. Complexity: amortized O(1), worst-case O(length t). *) val drop : 'a t -> [ `back | `front ] -> 'a t option val drop_exn : 'a t -> [ `back | `front ] -> 'a t val drop_front : 'a t -> 'a t option val drop_front_exn : 'a t -> 'a t val drop_back : 'a t -> 'a t option val drop_back_exn : 'a t -> 'a t (** [dequeue t side] produces [Option.both (peek t side) (drop t side)]. Complexity: amortized O(1), worst-case O(length t). *) val dequeue : 'a t -> [ `back | `front ] -> ('a * 'a t) option val dequeue_exn : 'a t -> [ `back | `front ] -> ('a * 'a t) val dequeue_front : 'a t -> ('a * 'a t) option val dequeue_front_exn : 'a t -> ('a * 'a t) val dequeue_back : 'a t -> ('a * 'a t) option val dequeue_back_exn : 'a t -> ('a * 'a t) module Stable : sig module V1 : sig type nonrec 'a t = 'a t with bin_io, compare, sexp end end core_kernel-113.00.00/src/fheap.ml000066400000000000000000000225171256461164500165310ustar00rootroot00000000000000open Std_internal module Node = struct type 'a t = { value : 'a ; children : 'a t list } end open Node type 'a t = { cmp : 'a -> 'a -> int ; length : int ; heap : 'a Node.t option } let create ~cmp = { cmp ; length = 0 ; heap = None } let merge ~cmp ({ value = e1; children = nl1 } as n1) ({ value = e2; children = nl2 } as n2) = if cmp e1 e2 < 0 then { value = e1; children = n2 :: nl1 } else { value = e2; children = n1 :: nl2 } ;; let merge_pairs ~cmp t = let rec loop acc t = match t with | [] -> acc | [head] -> head :: acc | head :: next1 :: next2 -> loop (merge ~cmp head next1 :: acc) next2 in match loop [] t with | [] -> None | [h] -> Some h | x :: xs -> Some (List.fold xs ~init:x ~f:(merge ~cmp)) ;; let add { cmp; length; heap } e = let new_node = { value = e; children = [] } in let heap = match heap with | None -> new_node | Some heap -> merge ~cmp new_node heap in { cmp; length = length + 1; heap = Some heap } ;; let top_exn t = match t.heap with | None -> failwith "Fheap.top_exn called on an empty heap" | Some { value; _ } -> value ;; let top t = try Some (top_exn t) with _ -> None let pop_exn { cmp; length; heap } = match heap with | None -> failwith "Heap.pop_exn called on an empty heap" | Some { value; children } -> let new_heap = merge_pairs ~cmp children in let t' = { cmp ; length = length - 1 ; heap = new_heap } in (value, t') ;; let pop t = try Some (pop_exn t) with _ -> None let remove_top t = try let (_, t') = pop_exn t in Some t' with | _ -> None ;; let pop_if t f = match top t with | None -> None | Some v -> if f v then pop t else None ;; let fold t ~init ~f = let rec loop acc to_visit = match to_visit with | [] -> acc | { value; children } :: rest -> let acc = f acc value in let to_visit = List.unordered_append children rest in loop acc to_visit in match t.heap with | None -> init | Some node -> loop init [node] ;; module C = Container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Define_using_fold end) let length t = t.length let is_empty t = t.heap = None let iter = C.iter let mem = C.mem let min_elt = C.min_elt let max_elt = C.max_elt let find = C.find let find_map = C.find_map let for_all = C.for_all let exists = C.exists let sum = C.sum let count = C.count let to_list = C.to_list (* We could avoid the intermediate list here, but it doesn't seem like a big deal. *) let to_array = C.to_array let of_fold c ~cmp fold = let h = create ~cmp in fold c ~init:h ~f:add ;; let of_list l ~cmp = of_fold l ~cmp List.fold let of_array arr ~cmp = of_fold arr ~cmp Array.fold let sexp_of_t sexp_of_a t = List.sexp_of_t sexp_of_a (to_list t) let to_sequence t = Sequence.unfold ~init:t ~f:pop TEST_MODULE = struct module type Heap_intf = sig type 'a t with sexp_of val create : cmp:('a -> 'a -> int) -> 'a t val add : 'a t -> 'a -> 'a t val pop : 'a t -> ('a * 'a t) option val length : 'a t -> int val top : 'a t -> 'a option val remove_top : 'a t -> 'a t option val of_list : 'a list -> cmp:('a -> 'a -> int) -> 'a t val to_list : 'a t -> 'a list val sum : (module Commutative_group.S with type t = 'sum) -> 'a t -> f:('a -> 'sum) -> 'sum end module That_heap : Heap_intf = struct type 'a t = { cmp : 'a -> 'a -> int; heap : 'a list; } let sexp_of_t sexp_of_v t = List.sexp_of_t sexp_of_v t.heap let create ~cmp = { cmp ; heap = [] } let add t v = { cmp = t.cmp ; heap = List.sort ~cmp:t.cmp (v :: t.heap)} let pop t = match t.heap with | [] -> None | x :: xs -> Some (x, { cmp = t.cmp ; heap = xs }) let length t = List.length t.heap let top t = List.hd t.heap let remove_top t = match t.heap with | [] -> None | _ :: xs -> Some { cmp = t.cmp ; heap = xs } let of_list l ~cmp = { cmp ; heap = List.sort ~cmp l} let to_list t = t.heap let sum m t ~f = List.sum m (to_list t) ~f end module This_heap : Heap_intf = struct type nonrec 'a t = 'a t with sexp_of let create ~cmp = create ~cmp let add = add let pop = pop let length = length let top = top let remove_top = remove_top let of_list = of_list let to_list = to_list let sum = sum end let this_to_string this = Sexp.to_string (This_heap.sexp_of_t Int.sexp_of_t this) let that_to_string that = Sexp.to_string (That_heap.sexp_of_t Int.sexp_of_t that) let length_check (t_a, t_b) = let this_len = This_heap.length t_a in let that_len = That_heap.length t_b in if this_len <> that_len then failwithf "error in length: %i (for %s) <> %i (for %s)" this_len (this_to_string t_a) that_len (that_to_string t_b) () else (t_a, t_b) ;; let create () = let cmp = Int.compare in (This_heap.create ~cmp, That_heap.create ~cmp) ;; let add (this_t, that_t) v = let this_t = This_heap.add this_t v in let that_t = That_heap.add that_t v in length_check (this_t, that_t) ;; let pop (this_t, that_t) = let res1 = This_heap.pop this_t in let res2 = That_heap.pop that_t in let f r default = match r with | None -> (None,default) | Some (r, t) -> (Some r, t) in let defaults = create () in let res1, this_t = f res1 (fst defaults) in let res2, that_t = f res2 (snd defaults) in if res1 <> res2 then failwithf "pop results differ (%s, %s)" (Option.value_map ~default:"None" ~f:Int.to_string res1) (Option.value_map ~default:"None" ~f:Int.to_string res2) () else (this_t, that_t) ;; let top (this_t, that_t) = let res1 = This_heap.top this_t in let res2 = That_heap.top that_t in if res1 <> res2 then failwithf "top results differ (%s, %s)" (Option.value_map ~default:"None" ~f:Int.to_string res1) (Option.value_map ~default:"None" ~f:Int.to_string res2) () else (this_t, that_t) ;; let remove_top (this_t, that_t) = let this_t = This_heap.remove_top this_t in let that_t = That_heap.remove_top that_t in let cmp = Int.compare in let this_default = This_heap.create ~cmp in let that_default = That_heap.create ~cmp in let this_t = Option.value ~default:this_default this_t in let that_t = Option.value ~default:that_default that_t in length_check (this_t, that_t) ;; let of_list l ~cmp = let this_t = This_heap.of_list l ~cmp in let that_t = That_heap.of_list l ~cmp in length_check (this_t, that_t) ;; let check (this_t, that_t) = let this_list = List.sort ~cmp:Int.compare (This_heap.to_list this_t) in let that_list = List.sort ~cmp:Int.compare (That_heap.to_list that_t) in <:test_eq< int list >> this_list that_list ;; let check_sum (this_t, that_t) = let this_sum = This_heap.sum (module Int) ~f:ident this_t in let that_sum = That_heap.sum (module Int) ~f:ident that_t in <:test_eq< int >> this_sum that_sum; this_sum ;; TEST_UNIT = let t = create () in let random = Random.State.make [| 4 |] in let rec loop ops dual = if ops = 0 then () else begin let r = Random.State.int random 100 in let new_dual = begin if r < 30 then add dual (Random.State.int random 100_000) else if r < 70 then pop dual else if r < 80 then top dual else if r < 90 then remove_top dual else begin check dual; dual end end in loop (ops -1) new_dual end in loop 10_000 t ;; TEST_UNIT = let l = List.init 10_000 ~f:(fun _ -> Random.int 100_000) in let dual = of_list ~cmp:Int.compare l in check dual; let sum0 = check_sum dual in let dual = add dual (-100) in let sum1 = check_sum dual in <:test_eq< int >> (sum0 - 100) sum1 end TEST_UNIT = let data = [ 0; 1; 2; 3; 4; 5; 6; 7 ] in let h = of_list data ~cmp:Int.compare in let (top_value, t) = pop_exn h in <:test_result< int >> ~expect:0 top_value; let list_sum = List.sum (module Int) data ~f:ident in let heap_fold_sum = fold t ~init:0 ~f:(fun sum v -> sum + v) in let heap_iter_sum = let r = ref 0 in iter t ~f:(fun v -> r := !r + v); !r in <:test_eq< int >> list_sum heap_fold_sum; <:test_eq< int >> list_sum heap_iter_sum; ;; TEST_UNIT = let data = [ 0; 1; 2; 3; 4; 5; 6; 7 ] in let t = of_list data ~cmp:Int.compare in let s = sum (module Int) t ~f:ident in <:test_result< int >> ~expect:28 s; let t = add t 8 in let top_value = top_exn t in <:test_result< int >> ~expect:0 top_value; let top_value, t = pop_exn t in <:test_result< int >> ~expect:0 top_value; <:test_result< int >> ~expect:1 (top_exn t); let len = length t in <:test_result< int >> ~expect:8 len; ;; BENCH_INDEXED "pop_add_with_existing_heap" initial_size [1; 10; 100; 1000; 10_000] = let a = Array.init initial_size ~f:(fun _ -> Random.int 100_000) in let h1 = of_array ~cmp:Int.compare a in (fun () -> let (e,h) = pop_exn h1 in ignore (add h e) ) core_kernel-113.00.00/src/fheap.mli000066400000000000000000000047571256461164500167100ustar00rootroot00000000000000(** Functional Heap implementation based on pairing-heap algorithm and immutable data structures. See more info at http://en.wikipedia.org/wiki/Pairing_heap. *) (** [t_of_sexp] is not supported, because of the difficulty involved in recreating the comparison function. *) type 'a t with sexp_of (** Even though [min_elt], [max_elt], and [to_list] are in [Container.S1], they are documented separately to make sure there is no confusion. *) include Container.S1 with type 'a t := 'a t (** The comparison function in [min_elt] and [max_elt] are independent of that used to order the heap. Since the provided [cmp] may be different from the one used to create the heap, it is necessary for these functions to traverse the entire heap. If you want to access the smallest element of the heap according to the heap's comparison function, you should use [top]. *) val min_elt : 'a t -> cmp:('a -> 'a -> int) -> 'a option val max_elt : 'a t -> cmp:('a -> 'a -> int) -> 'a option (** The elements of [to_list t] are not in any particular order. You need to sort the list afterwards if you want to get a sorted list. *) val to_list : 'a t -> 'a list (** [create ~cmp] returns a new min-heap that uses ordering function [cmp]. The top of the heap is the smallest element as determined by the provided comparison function. *) val create : cmp:('a -> 'a -> int) -> 'a t val of_array : 'a array -> cmp:('a -> 'a -> int) -> 'a t val of_list : 'a list -> cmp:('a -> 'a -> int) -> 'a t (** [add t v] returns the new heap after addition. Complexity O(1). *) val add : 'a t -> 'a -> 'a t (** This returns the top (i.e. smallest) element of the heap. Complexity O(1). *) val top : 'a t -> 'a option val top_exn : 'a t -> 'a (** [remove_top t] returns the new heap after a remove. It does nothing if [t] is empty. The amortized time per [remove_top t] (or [pop t], [pop_exn t], [pop_if t]) is O(lg n). The complexity of the worst case is O(n). *) val remove_top : 'a t -> 'a t option (** This removes and returns the top (i.e. least) element and the modified heap. *) val pop : 'a t -> ('a * 'a t) option val pop_exn : 'a t -> 'a * 'a t (** [pop_if t cond] returns [Some (top_element, rest_of_heap)] if [t] is not empty and its top element satisfies condition [cond], or [None] in any other case. *) val pop_if : 'a t -> ('a -> bool) -> ('a * 'a t) option (** [to_sequence t] is a sequence of the elements of [t] in ascending order. *) val to_sequence: 'a t -> 'a Sequence.t core_kernel-113.00.00/src/flags.ml000066400000000000000000000151031256461164500165330ustar00rootroot00000000000000open Std_internal include Flags_intf let create ~bit:n = if n < 0 || n > 62 then failwiths "Flags.create got invalid ~bit (must be between 0 and 62)" n <:sexp_of< int >>; Int63.shift_left Int63.one n ;; module Make (M : Make_arg) = struct type t = Int63.t with typerep let of_int = Int63.of_int let to_int_exn = Int63.to_int_exn let empty = Int63.zero let is_empty t = t = empty let (+) a b = Int63.bit_or a b let (-) a b = Int63.bit_and a (Int63.bit_not b) let intersect = Int63.bit_and let complement = Int63.bit_not let do_intersect t1 t2 = Int63.(<>) (Int63.bit_and t1 t2) Int63.zero let are_disjoint t1 t2 = Int63.(=) (Int63.bit_and t1 t2) Int63.zero let error message a sexp_of_a = let e = Error.create message a sexp_of_a in if M.should_print_error then eprintf "%s\n%!" (Sexp.to_string_hum (Error.sexp_of_t e)); Error.raise e; ;; let known = if M.remove_zero_flags then List.filter ~f:(fun (n, _) -> not (Int63.equal n Int63.zero)) M.known else M.known ;; let () = if not M.allow_intersecting then begin let rec check l ac = match l with | [] -> ac | (flag, name) :: l -> let bad = List.filter l ~f:(fun (flag', _) -> do_intersect flag flag') in let ac = if List.is_empty bad then ac else (flag, name, bad) :: ac in check l ac in let bad = check known [] in if not (List.is_empty bad) then error "Flags.Make got intersecting flags" bad (<:sexp_of< (Int63.t * string * (Int63.t * string) list) list >>); end; ;; let () = let bad = List.filter known ~f:(fun (flag, _) -> flag = Int63.zero) in if not (List.is_empty bad) then error "Flag.Make got flags with no bits set" bad (<:sexp_of< (Int63.t * string) list >>) ;; type sexp_format = string list with sexp let sexp_of_t = (* We reverse [known] so that the fold below accumulates from right to left, giving a final list with elements in the same order as [known]. *) let known = List.rev known in fun t -> let leftover, flag_names = List.fold known ~init:(t, []) ~f:(fun (t, flag_names) (flag, flag_name) -> if Int63.bit_and t flag = flag then (t - flag, flag_name :: flag_names) else (t, flag_names)) in if leftover = empty then <:sexp_of< sexp_format >> flag_names else <:sexp_of< string list * [ `unrecognized_bits of string ] >> (flag_names, `unrecognized_bits (sprintf "0x%Lx" (Int63.to_int64 leftover))) ;; let known_by_name = String.Table.of_alist_exn (List.map known ~f:(fun (mask, name) -> name, mask)) ;; let t_of_sexp sexp = List.fold (sexp |> <:of_sexp< sexp_format >>) ~init:empty ~f:(fun t name -> match Hashtbl.find known_by_name name with | Some mask -> t + mask | None -> of_sexp_error (sprintf "Flags.t_of_sexp got unknown name: %s" name) sexp) ;; let compare t u = if t = u then 0 else if t - u = empty then -1 else if u - t = empty then 1 else compare t u (* arbitrary but consistent with subset *) include Comparable.Make (struct type nonrec t = t with sexp, compare end) end (* Check that conflicting flags leads to an error. *) TEST = Result.is_error (Result.try_with (fun () -> let module M = Make (struct let allow_intersecting = false let should_print_error = false let known = [ Int63.of_int 0x1, ""; Int63.of_int 0x1, ""; ] let remove_zero_flags = false end) in ())) ;; TEST_MODULE = struct let a = Int63.of_int 0x1 let b = Int63.of_int 0x2 let c = Int63.of_int 0xC TEST_UNIT = List.iter [ -1; 63 ] ~f:(fun bit -> assert (Exn.does_raise (fun () -> create ~bit))) ;; TEST_UNIT = assert (create ~bit:0 = Int63.of_int 0x1); assert (create ~bit:1 = Int63.of_int 0x2); (* this constant is a string rather than an int so that it builds on 32bit *) assert (create ~bit:62 = Int63.of_string "0x4000_0000_0000_0000"); ;; module M = Make (struct let allow_intersecting = false let should_print_error = true let known = [ a, "a"; b, "b"; c, "c"; ] ;; let remove_zero_flags = false end) include M include Comparable.Check_sexp_conversion (struct include M let examples = [ a; b; c ] end) (* [sexp_of_t] *) TEST = Sexp.equal (sexp_of_t empty) Sexp.(List []) TEST = Sexp.equal (sexp_of_t a) Sexp.(List [ Atom "a" ]) TEST = Sexp.equal (sexp_of_t c) Sexp.(List [ Atom "c" ]) TEST = Sexp.equal (sexp_of_t (a + b)) Sexp.(List [ Atom "a"; Atom "b" ]) TEST_UNIT = ignore (sexp_of_t (Int63.of_int 0x10) : Sexp.t) (* [t_of_sexp] *) TEST = equal empty (t_of_sexp (Sexp.of_string "()")) TEST = equal a (t_of_sexp (Sexp.of_string "(a)")) TEST = equal c (t_of_sexp (Sexp.of_string "(c)")) TEST = equal (b + c) (t_of_sexp (Sexp.of_string "(b c)")) TEST = equal (b + c) (t_of_sexp (Sexp.of_string "(c b)")) TEST_UNIT = List.iter [ "a"; "(())"; "(a ())"; "(d)" ] ~f:(fun sexp -> let sexp = Sexp.of_string sexp in match Result.try_with (fun () -> t_of_sexp sexp) with | Error _ -> () | Ok t -> failwiths "invalid sexp converted" (sexp, t) <:sexp_of< Sexp.t * t >>) (* +, - *) TEST = equal (a + a) a TEST = equal (a + b) (b + a) TEST = equal (a - a) empty TEST = equal ((a + b) - a) b (* [intersect] *) TEST = equal (intersect a a) a TEST = equal (intersect a b) empty TEST = equal (intersect (a + b) a) a (* [complement] *) TEST = equal (intersect (complement a) b) b (* [do_intersect] *) TEST = do_intersect a a TEST = not (do_intersect a b) TEST = do_intersect (a + b) a TEST = do_intersect (a + b) b TEST = not (do_intersect (a + b) c) (* [are_disjoint] *) TEST = are_disjoint a empty TEST = not (are_disjoint a a) TEST = are_disjoint a b TEST = are_disjoint b a TEST = not (are_disjoint (a + b) a) TEST = are_disjoint (a + b) c (* compare *) TEST = Int.(=) (Int.compare 0 1) (-1) TEST = Int.(=) (compare a empty) 1 TEST = Int.(=) (compare c empty) 1 TEST = Int.(=) (compare a a) 0 TEST = Int.(=) (compare c c) 0 TEST = Int.(=) (compare empty empty) 0 TEST = Int.(=) (compare empty a) (-1) TEST = Int.(=) (compare empty c) (-1) TEST = Int.(=) (compare (a + c) a) 1 TEST = Int.(=) (compare (a + c) c) 1 TEST = Int.(=) (compare (b + b) b) 0 TEST = Int.(=) (compare b (b + c)) (-1) TEST = Int.(=) (compare b (b + c)) (-1) end core_kernel-113.00.00/src/flags.mli000066400000000000000000000001051256461164500167000ustar00rootroot00000000000000(** See flags_intf.ml for documentation. *) include Flags_intf.Flags core_kernel-113.00.00/src/flags_intf.ml000066400000000000000000000072571256461164500175660ustar00rootroot00000000000000(** [module Flags] implements Unix-style sets of flags that are represented as an [int] with various bits set, one bit for each flag. E.g. [Linux_ext.Epoll.Flag]. [Flags] defines a module type [Flags.S], the interface for a flags, and a functor [Flags.Make] for creating a flags implementation. *) module Int63 = Core_int63 (** [module type S] is the interface for a set of flags. Values of [type t] are set of flags, and the various functions operate on sets of flags. There is a finite universe of flags (in particular 63 flags, one for each bit). [sexp_of_t] and [t_of_sexp] use the flag names supplied to [Flags.Make]. *) module type S = sig type t with sexp, typerep include Comparable.S with type t := t (** consistent with subset *) val of_int : int -> t val to_int_exn : t -> int val empty : t val (+) : t -> t -> t (** set union, bitwise or *) val (-) : t -> t -> t (** set difference *) val intersect : t -> t -> t (** bitwise and *) val complement : t -> t (** bitwise not *) val is_empty : t -> bool val do_intersect : t -> t -> bool val are_disjoint : t -> t -> bool end module type Make_arg = sig (** An entry [flag, name] in [known] means that the bit(s) in [flag] is (are) called [name]; i.e. if [bit_and flags flag = flag], then the bit(s) is (are) set and [name] will appear in [sexp_of_t flags]. [known] is only used to make [sexp_of_t]'s output human readable. The flags in the output of [sexp_of_t] will occur in the same order as they appear in [known]. It is allowed to have a single flag with multiple bits set. It is an error if different flags intersect, and [allow_intersecting = false]. *) val known : (Int63.t * string) list (** If [remove_zero_flags], then all flags with value zero will be automatically removed from [known]. If [not remove_zero_flags], then it is an error for [known] to contain any flags with value zero. About this existence of this option: it seems better to make it an option here rather than do the filtering at the functor call site. It also makes clear to callers that they need to think about zero flags, and clear what they can do if they encounter them. *) val remove_zero_flags : bool (** [allow_intersecting] says whether to allow intersecting [known] flags. It is common to do [allow_intersecting = false], however in some situations, e.g. Unix open flags, the flags intersect. *) val allow_intersecting : bool (** [should_print_error] says whether to print an error message if there is an error in the known flags. It is typical to use [should_print_error = true] because [Flags.Make] is applied at the module level, where the exception raised isn't displayed nicely. *) val should_print_error : bool end module type Flags = sig module type Make_arg = Make_arg module type S = S (** [create ~bit:n] creates a flag with the [n]th bit set. [n] must be between 0 and 62. Typically a flag has one bit set; [create] is useful in exactly those cases. For flags with multiple bits one can either define the Int63.t directly or create it in terms of simpler flags, using [+] and [-]. *) val create : bit:int -> Int63.t (** [Flags.Make] builds a new flags module. If there is an error in the [known] flags, it behaves as per [on_error]. We expose [type t = int] in the result of [Flags.Make] so that one can easily use flag constants as values of the flag type without having to coerce them. It is typical to hide the [t = int] in another signature [S]. *) module Make (M : Make_arg) : S with type t = Int63.t end core_kernel-113.00.00/src/flat_array.ml000066400000000000000000000142511256461164500175660ustar00rootroot00000000000000open! Std_internal open! Int.Replace_polymorphic_compare module Slots = Tuple_type.Slots module Slot = struct type ('slots, 'a) t = int with sexp_of let equal (t1 : (_, _) t) t2 = t1 = t2 let t0 = 0 let t1 = 1 let t2 = 2 let t3 = 3 let t4 = 4 let t5 = 5 let t6 = 6 let t7 = 7 let t8 = 8 let t9 = 9 let t10 = 10 let t11 = 11 end let metadata_index = 0 let start_of_tuples_index = 1 module Metadata = struct (* We rely on immutability of the metadata in the [copy] function, which shares the pointer to the metadata between the original and the copy. *) type 'slots t = { slots : 'slots (* [slots_per_tuple] is number of slots in a tuple as seen by the user; i.e. not counting the next-free pointer. *) ; slots_per_tuple : int ; length : int (* [Obj_array.length dummy = slots_per_tuple]. *) ; dummy : Obj_array.t sexp_opaque } with fields, sexp_of let array_indices_per_tuple t = t.slots_per_tuple let array_length t = start_of_tuples_index + t.length * array_indices_per_tuple t let tuple_num_to_first_slot_index t tuple_num = start_of_tuples_index + tuple_num * array_indices_per_tuple t ;; let slot_index t tuple_num slot = tuple_num_to_first_slot_index t tuple_num + slot end open Metadata type 'slots t = Obj_array.t let metadata (type slots) (t : slots t) = (Obj.obj (Obj_array.unsafe_get t metadata_index) : slots Metadata.t) ;; let length t = (metadata t).length let slots t = (metadata t).slots let sexp_of_t sexp_of_slots t = Metadata.sexp_of_t sexp_of_slots (metadata t) let invariant slots_invariant t : unit = try let metadata = metadata t in let check f field = f (Field.get field metadata) in Metadata.Fields.iter ~slots:(check slots_invariant) ~slots_per_tuple:(check (fun slots_per_tuple -> assert (slots_per_tuple > 0))) ~length:(check (fun length -> assert (length >= 0); assert (Obj_array.length t = Metadata.array_length metadata))) ~dummy:(check (fun dummy -> assert (Obj_array.length dummy = metadata.slots_per_tuple))) with exn -> failwiths "Flat_array.invariant failed" (exn, t) <:sexp_of< exn * _ t >> ;; let set_metadata (type slots) (t : slots t) metadata = Obj_array.set t metadata_index (Obj.repr (metadata : slots Metadata.t)); ;; let create_array (type slots) (metadata : slots Metadata.t) : slots t = let t = Obj_array.create ~len:(Metadata.array_length metadata) in set_metadata t metadata; t ;; let check_index t metadata i = if i < 0 || i >= metadata.length then failwiths "Flat_array got invalid index" (i, t) <:sexp_of< int * _ t >>; ;; let set_to_init t tuple_num = let metadata = metadata t in check_index t metadata tuple_num; Obj_array.blit ~len:metadata.slots_per_tuple ~src:metadata.dummy ~src_pos:0 ~dst:t ~dst_pos:(tuple_num_to_first_slot_index metadata tuple_num) ;; let is_init t tuple_num = let metadata = metadata t in check_index t metadata tuple_num; let dummy = metadata.dummy in let r = ref true in for slot = 0 to metadata.slots_per_tuple - 1 do if not (phys_equal (Obj_array.get dummy slot) (Obj_array.get t (Metadata.slot_index metadata tuple_num slot))) then r := false done; !r ;; let create (type tuple) (slots : (tuple, _) Slots.t) ~len:length dummy = if length < 0 then failwiths "Flat_array.create got invalid length" length <:sexp_of< int >>; let slots_per_tuple = Slots.slots_per_tuple slots in let dummy = if slots_per_tuple = 1 then Obj_array.singleton (Obj.repr (dummy : tuple)) else (Obj.magic (dummy : tuple) : Obj_array.t) in let metadata = { Metadata. slots; slots_per_tuple; length; dummy } in let t = create_array metadata in for tuple_num = 0 to length - 1 do set_to_init t tuple_num; done; t ;; (* The backing obj_array is copied, including the pointer to the metadata. We don't have to deep copy the metadata because it is immutable. *) let copy t = Obj_array.copy t let get (type a) t i (slot : (_, a) Slot.t) = let metadata = metadata t in check_index t metadata i; (Obj.obj (Obj_array.unsafe_get t (Metadata.slot_index metadata i slot)) : a) ;; let unsafe_get (type a) t i (slot : (_, a) Slot.t) = let metadata = metadata t in (Obj.obj (Obj_array.unsafe_get t (Metadata.slot_index metadata i slot)) : a) ;; let set (type a) t i (slot : (_, a) Slot.t) a = let metadata = metadata t in check_index t metadata i; Obj_array.unsafe_set t (Metadata.slot_index metadata i slot) (Obj.repr (a : a)) ;; let unsafe_set (type a) t i (slot : (_, a) Slot.t) a = let metadata = metadata t in Obj_array.unsafe_set t (Metadata.slot_index metadata i slot) (Obj.repr (a : a)) ;; let get_all_slots (type tuple) (t : (tuple, _) Slots.t t) i = let metadata = metadata t in check_index t metadata i; let len = metadata.slots_per_tuple in if len = 1 then unsafe_get t i Slot.t0 else let obj = Obj_array.sub t ~pos:(Metadata.tuple_num_to_first_slot_index metadata i) ~len in (Obj.magic (obj : Obj_array.t) : tuple) ;; let set_all_slots (type tuple) (t : (tuple, _) Slots.t t) i tuple = let metadata = metadata t in check_index t metadata i; let len = metadata.slots_per_tuple in if len = 1 then unsafe_set t i Slot.t0 tuple else Obj_array.blit ~src:(Obj.magic (tuple : tuple) : Obj_array.t) ~src_pos:0 ~dst:t ~dst_pos:(Metadata.tuple_num_to_first_slot_index metadata i) ~len ;; let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len = let m = metadata src in Obj_array.blit ~src ~src_pos:(Metadata.tuple_num_to_first_slot_index m src_pos) ~dst ~dst_pos:(Metadata.tuple_num_to_first_slot_index (metadata dst) dst_pos) ~len:(len * m.slots_per_tuple) ;; include Blit.Make1 (struct module Slots = Slots type nonrec 'a t = 'a t with sexp_of type 'a z = 'a Slots.t1 t let length = length let get = get_all_slots let set = set_all_slots let unsafe_blit = unsafe_blit let create_like ~len t = let metadata = metadata t in create metadata.slots ~len metadata.dummy ;; let create_bool ~len = create Slots.t1 ~len false end) ;; core_kernel-113.00.00/src/flat_array.mli000066400000000000000000000050551256461164500177410ustar00rootroot00000000000000(** An array of flat tuples. A flat tuple is like an ordinary OCaml tuple, except it is second class and mutable. The flat tuples in a [Flat_array.t] are layed out sequentially in a single array, with each flat tuple's components immediately following the components of the prior flat tuple. A flat tuple is not first class -- one can only refer to a flat tuple via its index in the array holding it. Flat tuples are mutable via [Flat_array.set]. *) module Slots : Tuple_type.Slots module Slot : Tuple_type.Slot (** The type of a flat-tuple array. ['slots] will look like [('a1, ..., 'an) Slots.tn], and the array holds flat tuples of type ['a1 * ... * 'an]. *) type 'slots t with sexp_of include Blit. S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t (** [create slots ~len init] creates an array of flat tuples, whose slots are initialized to the slots of [init], which is an ordinary OCaml tuple. [create] raises if [len < 0]. *) val create : (('tuple, _) Slots.t as 'slots) -> len:int -> 'tuple -> 'slots t (** [copy a] returns a shallow copy of [a], that is, a fresh array containing the same elements as [a]. *) val copy : 'slots t -> 'slots t (** accessors *) val length : _ t -> int val slots : 'slots t -> 'slots (** These functions get and set individual slots of flat tuple [i] in array [t]. It is required that [0 <= i < length t].*) val get : ((_, 'v) Slots.t) t -> int -> ('v, 'a) Slot.t -> 'a val unsafe_get : ((_, 'v) Slots.t) t -> int -> ('v, 'a) Slot.t -> 'a val set : ((_, 'v) Slots.t) t -> int -> ('v, 'a) Slot.t -> 'a -> unit val unsafe_set : ((_, 'v) Slots.t) t -> int -> ('v, 'a) Slot.t -> 'a -> unit (** [set_to_init t i] sets flat tuple [i] to the [init] that was supplied to [create]. *) val set_to_init : _ t -> int -> unit (** [is_init t i] returns [true] iff flat tuple [i]'s slots are identical to those of the [init] supplied to [create]. *) val is_init : _ t -> int -> bool (** [get_all_slots t i] allocates a new ordinary OCaml tuple whose components are equal to the slots of the flat tuple at index [i] of [t]. This is esentially an allocation plus a blit from [t] to the newly allocated tuple. [set_all_slots t i tuple] sets all slots of the flat tuple at index [i] of [t] to their corresponding components of [tuple]. This is essentially a blit from [tuple] to [t]. It is required that [0 <= i < length t]. *) val get_all_slots : (('tuple, _) Slots.t) t -> int -> 'tuple val set_all_slots : (('tuple, _) Slots.t) t -> int -> 'tuple -> unit core_kernel-113.00.00/src/flat_array_debug.ml000066400000000000000000000060411256461164500207320ustar00rootroot00000000000000open! Std_internal open! Int.Replace_polymorphic_compare module type Flat_array = module type of Flat_array module Debug (Flat_array : Flat_array) : Flat_array = struct include Debug.Make () open Flat_array module Slots = Slots module Slot = Slot type nonrec 'a t = 'a t with sexp_of let create = create let invariant = invariant let length = length let slots = slots let debug x = debug (invariant ignore) ~module_name:"Flat_array" x let set_to_init t i = debug "set_to_init" [t] i <:sexp_of< int >> <:sexp_of< unit >> (fun () -> set_to_init t i) ;; let is_init t i = debug "is_init" [t] i <:sexp_of< int >> <:sexp_of< bool >> (fun () -> is_init t i) ;; let copy t = debug "copy" [t] () <:sexp_of< unit >> <:sexp_of< _ t >> (fun () -> copy t) ;; let debug_get name t i slot = debug name [t] (i, slot) <:sexp_of< int * (_, _) Slot.t >> <:sexp_of< _ >> (fun () -> get t i slot) ;; let get t i slot = debug_get "get" t i slot let unsafe_get t i slot = debug_get "unsafe_get" t i slot let debug_set name t i slot a = debug name [t] (i, slot) <:sexp_of< int * (_, _) Slot.t >> <:sexp_of< _ >> (fun () -> set t i slot a) ;; let set t i slot a = debug_set "set" t i slot a let unsafe_set t i slot a = debug_set "unsafe_set" t i slot a let get_all_slots t i = debug "get_all_slots" [t] i <:sexp_of< int >> <:sexp_of< _ >> (fun () -> get_all_slots t i) ;; let set_all_slots t i v = debug "set_all_slots" [t] i <:sexp_of< int >> <:sexp_of< _ >> (fun () -> set_all_slots t i v) ;; let blit ~src ~src_pos ~dst ~dst_pos ~len = debug "blit" [ src; dst ] (`src_pos src_pos, `len len, `dst_pos dst_pos) <:sexp_of< [ `src_pos of int ] * [ `len of int ] * [ `dst_pos of int ] >> <:sexp_of< unit >> (fun () -> blit ~src ~src_pos ~dst ~dst_pos ~len) ;; let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len = debug "unsafe_blit" [ src; dst ] (`src_pos src_pos, `len len, `dst_pos dst_pos) <:sexp_of< [ `src_pos of int ] * [ `len of int ] * [ `dst_pos of int ] >> <:sexp_of< unit >> (fun () -> unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len) ;; let blito ~src ?src_pos ?src_len ~dst ?dst_pos () = debug "blito" [ src; dst ] (`src_pos src_pos, `src_len src_len, `dst_pos dst_pos) <:sexp_of< [ `src_pos of int option ] * [ `src_len of int option ] * [ `dst_pos of int option ] >> <:sexp_of< unit >> (fun () -> blito ~src ?src_pos ?src_len ~dst ?dst_pos ()) ;; let sub t ~pos ~len = debug "sub" [ t ] (`pos pos, `len len) <:sexp_of< [ `pos of int ] * [ `len of int ] >> <:sexp_of< _ t >> (fun () -> sub t ~pos ~len) ;; let subo ?pos ?len t = debug "subo" [ t ] (`pos pos, `len len) <:sexp_of< [ `pos of int option ] * [ `len of int option ] >> <:sexp_of< _ t >> (fun () -> subo ?pos ?len t) ;; end core_kernel-113.00.00/src/flat_array_unit_tests.ml000066400000000000000000000103741256461164500220510ustar00rootroot00000000000000open! Std_internal open! Int.Replace_polymorphic_compare (* module Flat_array = Flat_array_debug.Debug (Flat_array) *) open Flat_array module Slots = Slots module Slot = Slot let does_raise = Exn.does_raise type nonrec 'slots t = 'slots t with sexp_of let invariant = invariant let create = create TEST_UNIT = List.iter [ Int.min_value; -1 ] ~f:(fun len -> assert (does_raise (fun () -> create Slots.t1 ~len ()))) ;; let length = length TEST_UNIT = List.iter [ 0; 1; 2; 100; 1_000 ] ~f:(fun len -> assert (length (create Slots.t1 ~len ()) = len)); ;; let copy = copy let get = get let get_all_slots = get_all_slots let is_init = is_init let set = set let set_all_slots = set_all_slots let set_to_init = set_to_init let slots = slots let unsafe_get = unsafe_get let unsafe_set = unsafe_set TEST_UNIT = let check (type tuple) (type variant) (type a) (init : a) (changed : a) (slots : (tuple, variant) Slots.t) (slot_list : (variant, a) Slot.t list) (make_tuple : a -> tuple) : unit = for len = 0 to 3 do let tuple = make_tuple init in let changed_tuple = make_tuple changed in let t = create slots ~len tuple in for i = 0 to len - 1 do assert (is_init t i); done; assert (phys_equal slots (Flat_array.slots t)); let t_copy = copy t in assert (length t_copy = len); for i = 0 to len - 1 do assert (Poly.equal (get_all_slots t_copy i) tuple); List.iter slot_list ~f:(fun slot -> set t_copy i slot changed); assert (not (is_init t_copy i)); done; (* Make sure changing [t_copy] didn't change [t]. *) for i = 0 to len - 1 do assert (Poly.equal (get_all_slots t i) tuple); done; (* Ensure invalid indices fail. *) List.iter [ -1; len ] ~f:(fun i -> assert (does_raise (fun () -> is_init t i)); assert (does_raise (fun () -> set_to_init t i)); assert (does_raise (fun () -> get_all_slots t i)); List.iter slot_list ~f:(fun slot -> assert (does_raise (fun () -> get t i slot)))); List.iter [ get, set; unsafe_get, unsafe_set; ] ~f:(fun (get, set) -> for i = 0 to len - 1 do assert (Poly.equal (get_all_slots t i) tuple); set_all_slots t i changed_tuple; assert (Poly.equal (get_all_slots t i) changed_tuple); set_all_slots t i tuple; List.iter slot_list ~f:(fun changed_slot -> set t i changed_slot changed; Flat_array.set_to_init t i; assert (Poly.equal (get t i changed_slot) init); set t i changed_slot changed; List.iter slot_list ~f:(fun slot -> for j = 0 to len - 1 do assert (Poly.equal (get t j slot) (if i = j && Slot.equal slot changed_slot then changed else init)); done); set t i changed_slot init); done); done in let check z = check 13 17 z in let slots0 () = [] in let slots1 () = slots0 () @ [ Slot.t0 ] in let slots2 () = slots1 () @ [ Slot.t1 ] in let slots3 () = slots2 () @ [ Slot.t2 ] in let slots4 () = slots3 () @ [ Slot.t3 ] in let slots5 () = slots4 () @ [ Slot.t4 ] in let slots6 () = slots5 () @ [ Slot.t5 ] in let slots7 () = slots6 () @ [ Slot.t6 ] in let slots8 () = slots7 () @ [ Slot.t7 ] in let slots9 () = slots8 () @ [ Slot.t8 ] in check Slots.t1 (slots1 ()) Fn.id; check Slots.t2 (slots2 ()) (fun i -> (i, i)); check Slots.t3 (slots3 ()) (fun i -> (i, i, i)); check Slots.t4 (slots4 ()) (fun i -> (i, i, i, i)); check Slots.t5 (slots5 ()) (fun i -> (i, i, i, i, i)); check Slots.t6 (slots6 ()) (fun i -> (i, i, i, i, i, i)); check Slots.t7 (slots7 ()) (fun i -> (i, i, i, i, i, i, i)); check Slots.t8 (slots8 ()) (fun i -> (i, i, i, i, i, i, i, i)); check Slots.t9 (slots9 ()) (fun i -> (i, i, i, i, i, i, i, i, i)); ;; (* These are unit tested via [Blit.Make_flat] in flat_tuple_array.ml *) let blit = blit let blito = blito let sub = sub let subo = subo let unsafe_blit = unsafe_blit core_kernel-113.00.00/src/flat_array_unit_tests.mli000066400000000000000000000002131256461164500222110ustar00rootroot00000000000000(** This signature is here to remind us to update the unit tests whenever we change [Flat_array]. *) include module type of Flat_array core_kernel-113.00.00/src/flat_queue.ml000066400000000000000000000214001256461164500175660ustar00rootroot00000000000000open! Std_internal open! Int.Replace_polymorphic_compare module A = Flat_array module Slots = A.Slots module Slot = A.Slot type 'slots t = { mutable elements : 'slots Flat_array.t (* [create_elements] is used when we need to create a new [elements] array when we shrink or grow the queue. We store it as a function that is closed over the[init] value, because we cannot store the [init] value for the array in [t], because we cannot write down its type in terms of ['slots]. *) ; create_elements : len:int -> 'slots Flat_array.t (* [mask = A.length elements - 1]. Having it makes it quick to go from a queue index to an array index -- since the array's length is a power of 2, [index land mask] equals [index mod A.length elements]. *) ; mutable mask : int (* [front] is the index of the first element in the queue. *) ; mutable front : int ; mutable length : int ; mutable num_mutations : int } with fields, sexp_of let capacity t = A.length t.elements let offset t i = (t.front + i) land t.mask let invariant slots_invariant t = Invariant.invariant _here_ t <:sexp_of< _ t >> (fun () -> let check f = Invariant.check_field t f in Fields.iter ~elements:(check (fun elements -> assert (Int.is_pow2 (capacity t)); A.invariant slots_invariant elements; for i = length t to capacity t - 1 do assert (A.is_init elements (offset t i)); done)) ~create_elements:ignore ~mask:(check (fun mask -> assert (mask = capacity t - 1))) ~front:(check (fun front -> assert (front >= 0); assert (front < capacity t))) ~length:(check (fun length -> assert (length >= 0); assert (length <= capacity t))) ~num_mutations:(check (fun num_mutations -> assert (num_mutations >= 0)))) ;; let create (type tuple) (type variant) ?capacity (slots : (tuple, variant) Slots.t) : (tuple, variant) Slots.t t = let slots_per_tuple = Slots.slots_per_tuple slots in let init : tuple = (* The uses of [Obj.magic] are to create a dummy value that will be stored in the slots of array elements that don't currently hold queue elements. It is a bug (of the segfault variety) in [Flat_queue] if this dummy value is ever exposed to user code. *) if slots_per_tuple = 1 then (Obj.magic None : tuple) else (Obj.magic (Obj_array.create ~len:slots_per_tuple) : tuple) in let capacity = match capacity with | None -> 1 | Some capacity -> if capacity <= 0 then failwiths "Flat_queue.create got nonpositive capacity" capacity <:sexp_of< int >> else Int.ceil_pow2 capacity in let create_elements ~len : (tuple, variant) Slots.t A.t = A.create slots ~len init in { create_elements ; mask = capacity - 1 ; elements = create_elements ~len:capacity ; front = 0 ; length = 0 ; num_mutations = 0 } ;; let is_empty t = length t = 0 let is_full t = length t = capacity t let inc_num_mutations t = t.num_mutations <- t.num_mutations + 1 let drop_front ?(n = 1) t = if n < 0 || n > length t then failwiths "Flat_queue.drop_front got invalid n" (n, t) <:sexp_of< int * _ t >>; inc_num_mutations t; for _i = 1 to n do A.set_to_init t.elements t.front; t.front <- offset t 1; t.length <- t.length - 1; done; ;; let clear t = inc_num_mutations t; for i = 0 to length t - 1 do A.set_to_init t.elements (offset t i); done; t.length <- 0; t.front <- 0; ;; let unsafe_get t i slot = A.unsafe_get t.elements (offset t i) slot let unsafe_set t i slot a = inc_num_mutations t; A.unsafe_set t.elements (offset t i) slot a; ;; let check_index t i = if i < 0 || i >= t.length then failwiths "invalid index in Flat_queue" (i, t) <:sexp_of< int * _ t >>; ;; let get t i slot = check_index t i; unsafe_get t i slot let set t i slot a = check_index t i; unsafe_set t i slot a let get_all_slots t i = check_index t i; A.get_all_slots t.elements (offset t i) let set_all_slots t i tuple = inc_num_mutations t; check_index t i; A.set_all_slots t.elements (offset t i) tuple; ;; let resize t ~capacity = let old_elements = t.elements in let old_front = t.front in t.mask <- capacity - 1; t.elements <- t.create_elements ~len:capacity; let len1 = Int.min t.length (A.length old_elements - old_front) in let len2 = t.length - len1 in A.blit ~len:len1 ~src:old_elements ~src_pos:old_front ~dst:t.elements ~dst_pos:0; A.blit ~len:len2 ~src:old_elements ~src_pos:0 ~dst:t.elements ~dst_pos:len1; t.front <- 0; ;; (* [maybe_grow] and [set_capacity] both increment [t.num_mutations] directly rather than relying on [resize] to increment it so that it is incremented even if the underlying array doesn't need to change. [resize] does not need to increment it because these are the only call sites. *) let maybe_grow t = inc_num_mutations t; if is_full t then resize t ~capacity:(capacity t * 2) ;; let set_capacity t new_capacity = inc_num_mutations t; let new_capacity = Int.ceil_pow2 (max new_capacity (length t)) in if new_capacity <> capacity t then resize t ~capacity:new_capacity; ;; (* In the [enqueueN] functions, [maybe_grow] increments [t.num_mutations], so it doesn't need to be incremented again. *) let enqueue1 t a0 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; t.length <- t.length + 1; ;; let enqueue2 t a0 a1 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; A.unsafe_set elements i Slot.t1 a1; t.length <- t.length + 1; ;; let enqueue3 t a0 a1 a2 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; A.unsafe_set elements i Slot.t1 a1; A.unsafe_set elements i Slot.t2 a2; t.length <- t.length + 1; ;; let enqueue4 t a0 a1 a2 a3 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; A.unsafe_set elements i Slot.t1 a1; A.unsafe_set elements i Slot.t2 a2; A.unsafe_set elements i Slot.t3 a3; t.length <- t.length + 1; ;; let enqueue5 t a0 a1 a2 a3 a4 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; A.unsafe_set elements i Slot.t1 a1; A.unsafe_set elements i Slot.t2 a2; A.unsafe_set elements i Slot.t3 a3; A.unsafe_set elements i Slot.t4 a4; t.length <- t.length + 1; ;; let enqueue6 t a0 a1 a2 a3 a4 a5 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; A.unsafe_set elements i Slot.t1 a1; A.unsafe_set elements i Slot.t2 a2; A.unsafe_set elements i Slot.t3 a3; A.unsafe_set elements i Slot.t4 a4; A.unsafe_set elements i Slot.t5 a5; t.length <- t.length + 1; ;; let enqueue7 t a0 a1 a2 a3 a4 a5 a6 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; A.unsafe_set elements i Slot.t1 a1; A.unsafe_set elements i Slot.t2 a2; A.unsafe_set elements i Slot.t3 a3; A.unsafe_set elements i Slot.t4 a4; A.unsafe_set elements i Slot.t5 a5; A.unsafe_set elements i Slot.t6 a6; t.length <- t.length + 1; ;; let enqueue8 t a0 a1 a2 a3 a4 a5 a6 a7 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; A.unsafe_set elements i Slot.t1 a1; A.unsafe_set elements i Slot.t2 a2; A.unsafe_set elements i Slot.t3 a3; A.unsafe_set elements i Slot.t4 a4; A.unsafe_set elements i Slot.t5 a5; A.unsafe_set elements i Slot.t6 a6; A.unsafe_set elements i Slot.t7 a7; t.length <- t.length + 1; ;; let enqueue9 t a0 a1 a2 a3 a4 a5 a6 a7 a8 = maybe_grow t; let elements = t.elements in let i = offset t t.length in A.unsafe_set elements i Slot.t0 a0; A.unsafe_set elements i Slot.t1 a1; A.unsafe_set elements i Slot.t2 a2; A.unsafe_set elements i Slot.t3 a3; A.unsafe_set elements i Slot.t4 a4; A.unsafe_set elements i Slot.t5 a5; A.unsafe_set elements i Slot.t6 a6; A.unsafe_set elements i Slot.t7 a7; A.unsafe_set elements i Slot.t8 a8; t.length <- t.length + 1; ;; let ensure_no_mutation t num_mutations = if t.num_mutations <> num_mutations then failwiths "mutation of queue during iteration" t <:sexp_of< _ t >>; ;; let fold t ~init ~f = let num_mutations = t.num_mutations in let r = ref init in for i = 0 to length t - 1 do r := f !r (get_all_slots t i); ensure_no_mutation t num_mutations; done; !r ;; let iter t ~f = let num_mutations = t.num_mutations in for i = 0 to length t - 1 do f (get_all_slots t i); ensure_no_mutation t num_mutations; done; ;; core_kernel-113.00.00/src/flat_queue.mli000066400000000000000000000113551256461164500177470ustar00rootroot00000000000000(** A queue of flat tuples, represented in a {!Flat_array}. The elements of a queue are numbered 0, 1, ..., [length t - 1], where element [0] is at the front of the queue. One can access the [j]'th component of the [i]'th element using [get t i Slot.tj]. A flat tuple is like an ordinary OCaml tuple, except it is second class and mutable. The flat tuples in a flat queue are layed out sequentially, with each flat tuple's components immediately following the components of the prior flat tuple. A flat tuple is not first class -- one can only refer to a flat tuple via its index in the queue holding it. Flat tuples are mutable via [Flat_queue.set]. *) module Slots : Tuple_type.Slots module Slot : Tuple_type.Slot (** The type of a flat queue. ['slots] will look like [('a1, ..., 'an) Slots.tn], and the queue holds flat tuples of type ['a1 * ... * 'an]. *) type 'slots t with sexp_of include Invariant.S1 with type 'a t := 'a t (** [create ?capacity slots] creates an empty queue with capacity at least the supplied [capacity]. It is an error if [capacity <= 0]. *) val create : ?capacity : int -> ((_, _) Slots.t as 'slots) -> 'slots t (** [capacity t] returns the length of the array backing [t]. Enqueueing values will not cause the array to grow as long as [length t <= capacity t]. A queue at capacity will automatically increase capacity when enqueueing. The capacity never decreases automatically; one can only decrease capacity via [set_capacity]. *) val capacity : _ t -> int (** [set_capacity t capacity] sets the length of the array backing [t] to as small as value as possible that is not less than [max capacity (length t)]. To shrink as much as possible, do [set_capacity t 0]. *) val set_capacity : _ t -> int -> unit val length : _ t -> int val is_empty : _ t -> bool (** These functions get and set individual slots of flat tuple [i] in queue [t]. It is required that [0 <= i < length t]. *) val get : ((_, 'v) Slots.t) t -> int -> ('v, 'a) Slot.t -> 'a val unsafe_get : ((_, 'v) Slots.t) t -> int -> ('v, 'a) Slot.t -> 'a val set : ((_, 'v) Slots.t) t -> int -> ('v, 'a) Slot.t -> 'a -> unit val unsafe_set : ((_, 'v) Slots.t) t -> int -> ('v, 'a) Slot.t -> 'a -> unit (** [drop_front ?n t] drops the the first [n] elements of [t]. It raises if [n < 0 || n > length t]. [Flat_queue] does not have [dequeue] or [dequeue_exn] because the expected usage is to use [get t 0 Slot.tj] to access the front of the queue, and then to use [drop_front] to remove it. This usage avoids ever allocating an ordinary OCaml tuple. *) val drop_front : ?n : int (** default is 1. *) -> _ t -> unit (** [clear t] removes all elements from [t]. *) val clear : _ t -> unit (** There is an [enqueueN] function for each possible arity of a flat queue. *) val enqueue1 : 'a0 Slots.t1 t -> 'a0 -> unit val enqueue2 : ('a0, 'a1) Slots.t2 t -> 'a0 -> 'a1 -> unit val enqueue3 : ('a0, 'a1, 'a2) Slots.t3 t -> 'a0 -> 'a1 -> 'a2 -> unit val enqueue4 : ('a0, 'a1, 'a2, 'a3) Slots.t4 t -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> unit val enqueue5 : ('a0, 'a1, 'a2, 'a3, 'a4) Slots.t5 t -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> unit val enqueue6 : ('a0, 'a1, 'a2, 'a3, 'a4, 'a5) Slots.t6 t -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> unit val enqueue7 : ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6) Slots.t7 t -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> unit val enqueue8 : ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6, 'a7) Slots.t8 t -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> unit val enqueue9 : ('a0, 'a1, 'a2, 'a3, 'a4, 'a5, 'a6, 'a7, 'a8) Slots.t9 t -> 'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> unit (** The functions below deal with Flat-array tuples as ordinary OCaml tuples. These are intended for convenience but not for performance-critical code, due to the tuple allocation. *) (** [get_all_slots t i] allocates a new ordinary OCaml tuple whose components are equal to the slots of the flat tuple at index [i] of [t]. This is esentially an allocation plus a blit from [t] to the newly allocated tuple. [set_all_slots t i tuple] sets all slots of the flat tuple at index [i] of [t] to their corresponding components of [tuple]. This is essentially a blit from [tuple] to [t]. It is required that [0 <= i < length t]. *) val get_all_slots : (('tuple, _) Slots.t) t -> int -> 'tuple val set_all_slots : (('tuple, _) Slots.t) t -> int -> 'tuple -> unit (** In [iter t ~f] and [fold t ~init ~f], if [f] mutates [t], then the iteration will raise. *) val fold : (('tuple, _) Slots.t) t -> init:'a -> f:('a -> 'tuple -> 'a ) -> 'a val iter : (('tuple, _) Slots.t) t -> f:( 'tuple -> unit) -> unit core_kernel-113.00.00/src/flat_queue_debug.ml000066400000000000000000000072021256461164500207400ustar00rootroot00000000000000open! Std_internal open! Int.Replace_polymorphic_compare module Debug (Flat_queue : module type of Flat_queue) = struct include Debug.Make () open Flat_queue module Slots = Slots module Slot = Slot type nonrec 'a t = 'a t with sexp_of let invariant = invariant let debug x = debug (invariant ignore) ~module_name:"Flat_queue" x let create ?capacity slots = debug "create" [] slots <:sexp_of< (_, _) Slots.t >> <:sexp_of< _ t >> (fun () -> create ?capacity slots) ;; let capacity t = debug "capacity" [t] t <:sexp_of< _ t >> <:sexp_of< int >> (fun () -> capacity t) ;; let set_capacity t capacity = debug "set_capacity" [t] (t, capacity) <:sexp_of< _ t * int >> <:sexp_of< unit >> (fun () -> set_capacity t capacity) ;; let length t = debug "length" [t] t <:sexp_of< _ t >> <:sexp_of< int >> (fun () -> length t) ;; let is_empty t = debug "is_empty" [t] t <:sexp_of< _ t >> <:sexp_of< bool >> (fun () -> is_empty t) ;; let clear t = debug "clear" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> clear t) ;; let drop_front ?n t = debug "drop_front" [t] (t, n) <:sexp_of< _ t * int option >> <:sexp_of< unit >> (fun () -> drop_front t ?n) ;; let enqueue1 t a0 = debug "enqueue1" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue1 t a0) ;; let enqueue2 t a0 a1 = debug "enqueue2" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue2 t a0 a1) ;; let enqueue3 t a0 a1 a2 = debug "enqueue3" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue3 t a0 a1 a2) ;; let enqueue4 t a0 a1 a2 a3 = debug "enqueue4" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue4 t a0 a1 a2 a3) ;; let enqueue5 t a0 a1 a2 a3 a4 = debug "enqueue5" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue5 t a0 a1 a2 a3 a4) ;; let enqueue6 t a0 a1 a2 a3 a4 a5 = debug "enqueue6" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue6 t a0 a1 a2 a3 a4 a5) ;; let enqueue7 t a0 a1 a2 a3 a4 a5 a6 = debug "enqueue7" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue7 t a0 a1 a2 a3 a4 a5 a6) ;; let enqueue8 t a0 a1 a2 a3 a4 a5 a6 a7 = debug "enqueue8" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue8 t a0 a1 a2 a3 a4 a5 a6 a7) ;; let enqueue9 t a0 a1 a2 a3 a4 a5 a6 a7 a8 = debug "enqueue9" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> enqueue9 t a0 a1 a2 a3 a4 a5 a6 a7 a8) ;; let debug_get name t i slot = debug name [t] (t, i, slot) <:sexp_of< _ t * int * (_, _) Slot.t >> <:sexp_of< _ >> (fun () -> get t i slot) ;; let get t i slot = debug_get "get" t i slot let unsafe_get t i slot = debug_get "unsafe_get" t i slot let debug_set name t i slot a = debug name [t] (t, i, slot) <:sexp_of< _ t * int * (_, _) Slot.t >> <:sexp_of< unit >> (fun () -> set t i slot a) ;; let set t i slot a = debug_set "set" t i slot a let unsafe_set t i slot a = debug_set "unsafe_set" t i slot a let get_all_slots t i = debug "get_all_slots" [t] (t, i) <:sexp_of< _ t * int >> <:sexp_of< _ >> (fun () -> get_all_slots t i) ;; let set_all_slots t i tuple = debug "set_all_slots" [t] (t, i) <:sexp_of< _ t * int >> <:sexp_of< _ >> (fun () -> set_all_slots t i tuple) ;; let fold t ~init ~f = debug "fold" [t] t <:sexp_of< _ t >> <:sexp_of< _ >> (fun () -> fold t ~init ~f) ;; let iter t ~f = debug "iter" [t] t <:sexp_of< _ t >> <:sexp_of< unit >> (fun () -> iter t ~f) ;; end core_kernel-113.00.00/src/flat_queue_debug.mli000066400000000000000000000002511256461164500211060ustar00rootroot00000000000000module Debug (Flat_queue : module type of Flat_queue) : sig include module type of Flat_queue val check_invariant : bool ref val show_messages : bool ref end core_kernel-113.00.00/src/flat_queue_unit_tests.ml000066400000000000000000000265041256461164500220610ustar00rootroot00000000000000open! Std_internal open! Int.Replace_polymorphic_compare let eprints = Debug.eprints module Flat_queue = Flat_queue_debug.Debug (Flat_queue) let () = Flat_queue.show_messages := false open Flat_queue module Slots = Slots module Slot = Slot let does_raise = Exn.does_raise type nonrec 'slots t = 'slots t with sexp_of let invariant = invariant let capacity = capacity let clear = clear let create = create let drop_front = drop_front let enqueue1 = enqueue1 let enqueue2 = enqueue2 let enqueue3 = enqueue3 let enqueue4 = enqueue4 let enqueue5 = enqueue5 let enqueue6 = enqueue6 let enqueue7 = enqueue7 let enqueue8 = enqueue8 let enqueue9 = enqueue9 let fold = fold let get = get let get_all_slots = get_all_slots let is_empty = is_empty let iter = iter let length = length let set = set let set_all_slots = set_all_slots let set_capacity = set_capacity let unsafe_get = unsafe_get let unsafe_set = unsafe_set TEST_UNIT = let num_enqueues = 5 in let check (type a) (type tuple) (type variant) (init : a) (changed : a) (slots : (tuple, variant) Slots.t) (all_slots : (variant, a) Slot.t list) (make_tuple : a -> tuple) (_sexp_of_tuple : tuple -> Sexp.t) (enqueue : (tuple, variant) Slots.t t -> a -> unit) : unit = if false then eprints "testing" slots <:sexp_of< (_, _) Slots.t >>; let changed_tuple = make_tuple changed in let init_tuple = make_tuple init in let t = create slots in let index_is_valid i = List.for_all all_slots ~f:(fun slot -> let b1 = is_ok (Result.try_with (fun () -> ignore (get t i slot : a))) in let b2 = is_ok (Result.try_with (fun () -> set t i slot changed)) in let b3 = is_ok (Result.try_with (fun () -> ignore (get_all_slots t i : tuple))) in assert (Bool.equal b1 b2 && Bool.equal b2 b3); b1) in let behaves_like_it_is_empty t = length t = 0 && is_empty t && does_raise (fun () -> drop_front t) && not (index_is_valid (-1)) && not (index_is_valid 0) && (iter t ~f:(fun _ -> assert false); true) && fold t ~init:true ~f:(fun _ _ -> false) in List.iter [ Int.min_value; -1; 0 ] ~f:(fun capacity -> assert (does_raise (fun () -> create ~capacity slots))); List.iter [ 1; 100 ] ~f:(fun capacity -> let t = create ~capacity slots in assert (Flat_queue.capacity t >= capacity); List.iter [ Int.min_value; -1; 0 ] ~f:(fun capacity -> assert (does_raise (fun () -> set_capacity t capacity))); List.iter [ 1; 2; 100 ] ~f:(fun capacity -> set_capacity t capacity; assert (Flat_queue.capacity t >= capacity)); for _i = 1 to 10 do enqueue t changed; done; List.iter [ Int.min_value; -1; 0; length t - 1 ] ~f:(fun capacity -> set_capacity t capacity); set_capacity t (length t)); assert (behaves_like_it_is_empty t); for i = 1 to num_enqueues do enqueue t changed; assert (length t = i); assert (not (is_empty t)); assert (not (index_is_valid (-1))); for index = 0 to i - 1 do assert (index_is_valid index); done; assert (not (index_is_valid i)); done; assert (num_enqueues = fold t ~init:0 ~f:(fun i tuple -> assert (Poly.equal tuple changed_tuple); i + 1)); let () = let r = ref 0 in iter t ~f:(fun tuple -> incr r; assert (Poly.equal tuple changed_tuple)); assert (!r = num_enqueues); in for i = 0 to num_enqueues - 1 do assert (Poly.equal (get_all_slots t i) changed_tuple); set_all_slots t i init_tuple; assert (Poly.equal (get_all_slots t i) init_tuple); set_all_slots t i changed_tuple; List.iter all_slots ~f:(fun slot -> assert (Poly.equal (get t i slot) changed); assert (Poly.equal (unsafe_get t i slot) changed); set t i slot init; assert (Poly.equal (get t i slot) init); assert (Poly.equal (unsafe_get t i slot) init)); done; for i = 1 to num_enqueues do drop_front t; assert (length t = num_enqueues - i); done; assert (behaves_like_it_is_empty t); (* Check the circular buffer. *) for _i = 1 to 2 do enqueue t changed; done; for _i = 1 to 100 do enqueue t changed; drop_front t; assert (length t = 2); done; for _i = 1 to 2 do drop_front t; done; assert (behaves_like_it_is_empty t); (* Check [clear]. *) for i = 0 to 5 do for _j = 1 to i do enqueue t changed; done; clear t; assert (behaves_like_it_is_empty t); done; (* Check growing with the front at various places. *) for shift = 0 to 3 do let t = create slots in for _i = 1 to 3 do enqueue t changed; done; for _i = 1 to shift do enqueue t changed; drop_front t; done; for _i = 1 to 4 do enqueue t changed; done; for i = 0 to 6 do assert (Poly.equal (get_all_slots t i) changed_tuple); done; assert (not (index_is_valid 7)); done in let check z = check 13 17 z in let slots0 () = [] in let slots1 () = slots0 () @ [ Slot.t0 ] in let slots2 () = slots1 () @ [ Slot.t1 ] in let slots3 () = slots2 () @ [ Slot.t2 ] in let slots4 () = slots3 () @ [ Slot.t3 ] in let slots5 () = slots4 () @ [ Slot.t4 ] in let slots6 () = slots5 () @ [ Slot.t5 ] in let slots7 () = slots6 () @ [ Slot.t6 ] in let slots8 () = slots7 () @ [ Slot.t7 ] in let slots9 () = slots8 () @ [ Slot.t8 ] in check Slots.t1 (slots1 ()) (fun i -> i) <:sexp_of< int >> (fun t a -> enqueue1 t a); check Slots.t2 (slots2 ()) (fun i -> (i, i)) <:sexp_of< int * int >> (fun t a -> enqueue2 t a a); check Slots.t3 (slots3 ()) (fun i -> (i, i, i)) <:sexp_of< int * int * int >> (fun t a -> enqueue3 t a a a); check Slots.t4 (slots4 ()) (fun i -> (i, i, i, i)) <:sexp_of< int * int * int * int >> (fun t a -> enqueue4 t a a a a); check Slots.t5 (slots5 ()) (fun i -> (i, i, i, i, i)) <:sexp_of< int * int * int * int * int >> (fun t a -> enqueue5 t a a a a a); check Slots.t6 (slots6 ()) (fun i -> (i, i, i, i, i, i)) <:sexp_of< int * int * int * int * int * int >> (fun t a -> enqueue6 t a a a a a a); check Slots.t7 (slots7 ()) (fun i -> (i, i, i, i, i, i, i)) <:sexp_of< int * int * int * int * int * int * int >> (fun t a -> enqueue7 t a a a a a a a); check Slots.t8 (slots8 ()) (fun i -> (i, i, i, i, i, i, i, i)) <:sexp_of< int * int * int * int * int * int * int * int >> (fun t a -> enqueue8 t a a a a a a a a); check Slots.t9 (slots9 ()) (fun i -> (i, i, i, i, i, i, i, i, i)) <:sexp_of< int * int * int * int * int * int * int * int * int >> (fun t a -> enqueue9 t a a a a a a a a a); ;; TEST_UNIT = (* mutation during [fold] *) let t = create Slots.t1 in enqueue1 t (); assert (does_raise (fun () -> fold t ~init:() ~f:(fun () () -> enqueue1 t ()))); ;; TEST_UNIT = (* mutation during [iter] *) let t = create Slots.t1 in enqueue1 t (); assert (does_raise (fun () -> iter t ~f:(fun () -> enqueue1 t ()))); ;; (* Compare [Flat_queue] with [Core_queue]. *) TEST_MODULE = struct module type Queue = sig type 'a t with sexp_of val create : unit -> _ t val enqueue : 'a t -> 'a -> unit val dequeue : 'a t -> 'a option val to_list : 'a t -> 'a list end module This_queue : Queue = struct type 'a t = 'a Slots.t1 Flat_queue.t with sexp_of let create () = Flat_queue.create Slots.t1 let enqueue t a = Flat_queue.enqueue1 t a let dequeue t = if is_empty t then None else let a = Flat_queue.get t 0 Slot.t0 in Flat_queue.drop_front t; Some a ;; let to_list t = List.init (Flat_queue.length t) ~f:(fun i -> Flat_queue.get t i Slot.t0) ;; end module That_queue : Queue = struct include Core_queue (* [Core_queue.create] takes an optional argument, so this is necessary *) let create () = create () end module Queue : sig include Queue val create : (module Queue) -> _ t end = struct module type Q = sig include Queue type a val t : a t end type 'a t = (module Q with type a = 'a) let sexp_of_t (type a) sexp_of_a (t : a t) = let module Q = (val t) in <:sexp_of< a Q.t >> Q.t ;; let create (type a) (q : (module Queue)) : a t = let module Q = (val q) in (module struct include Q type nonrec a = a let t = Q.create () end) ;; let enqueue (type a) (t : a t) a = let module Q = (val t) in Q.enqueue Q.t a let dequeue (type a) (t : a t) = let module Q = (val t) in Q.dequeue Q.t let to_list (type a) (t : a t) = let module Q = (val t) in Q.to_list Q.t end let all_are_equal l ~equal = match l with | [] -> true | a1 :: ls -> with_return (fun r -> let rec loop a1 ls = match ls with | [] -> () | a2 :: ls -> if not (equal a1 a2) then r.return false; loop a2 ls in loop a1 ls; true) ;; module Here = Source_code_position module type Elt = sig type t with sexp_of val equal : t -> t -> bool end module Queues : sig type 'a t with sexp_of val create : (module Elt with type t = 'a) -> (module Queue) list -> 'a t val enqueue : 'a t -> 'a -> unit val dequeue : 'a t -> 'a option end = struct type 'a t = { elt : (module Elt with type t = 'a) ; queues : 'a Queue.t list; } let equal_a (type a) (t : a t) = let module Elt = (val t.elt) in Elt.equal let sexp_of_a (type a) (t : a t) = let module Elt = (val t.elt) in Elt.sexp_of_t let sexp_of_t sexp_of_a t = <:sexp_of< a Queue.t list >> t.queues let ensure_consistent here t = if not (all_are_equal (List.map t.queues ~f:Queue.to_list) ~equal:(fun l1 l2 -> List.equal l1 l2 ~equal:(equal_a t))) then let sexp_of_a = sexp_of_a t in failwiths "inconsistent queues" (here, t) <:sexp_of< Here.t * a t >> ;; let create elt queues = if List.is_empty queues then failwiths "empty queues" _here_ <:sexp_of< Here.t >>; let t = { elt ; queues = List.map queues ~f:Queue.create } in ensure_consistent _here_ t; t ;; let enqueue t a = List.iter t.queues ~f:(fun q -> Queue.enqueue q a); ensure_consistent _here_ t; ;; let dequeue t = let as_ = List.map t.queues ~f:(fun q -> Queue.dequeue q) in if not (all_are_equal as_ ~equal:(Option.equal (equal_a t))) then begin let sexp_of_a = sexp_of_a t in failwiths "dequeue inconsistency" (_here_, t, as_) <:sexp_of< Here.t * a t * a option list >>; end; ensure_consistent _here_ t; List.hd_exn as_; ;; end TEST_UNIT = let random_state = Random.State.make [||] in let qs = Queues.create (module Int) [ (module This_queue); (module That_queue)] in let r = ref 0 in for _i = 1 to 1_000 do let op = Random.State.int random_state 10 in if op < 7 then (incr r; Queues.enqueue qs !r) else ignore (Queues.dequeue qs : int option); done; ;; end core_kernel-113.00.00/src/flat_queue_unit_tests.mli000066400000000000000000000002131256461164500222170ustar00rootroot00000000000000(** This signature is here to remind us to update the unit tests whenever we change [Flat_queue]. *) include module type of Flat_queue core_kernel-113.00.00/src/float.ml000066400000000000000000001622461256461164500165570ustar00rootroot00000000000000open Typerep_lib.Std open Sexplib.Std open Bin_prot.Std open Result.Export module List = ListLabels module Sexp = Sexplib.Sexp module String = Core_string open Core_printf INCLUDE "config.mlh" type 'a bound = 'a Comparable.bound = Incl of 'a | Excl of 'a | Unbounded let failwiths = Error.failwiths module T = struct type t = float with sexp, bin_io, typerep let compare (x : t) y = compare x y let equal (x : t) y = x = y external hash : float -> int = "caml_hash_double" "noalloc" TEST_UNIT = List.iter ~f:(fun float -> assert (hash float = Caml.Hashtbl.hash float)) [ 0.926038888360971146 ; 34.1638588598232076 ] ;; end include T type outer = t with sexp, bin_io, typerep (* alias for use by sub-modules *) let to_float x = x let of_float x = x let of_string s = try Pervasives.float_of_string s with | _ -> invalid_argf "Float.of_string %s" s () ;; external format_float : string -> float -> string = "caml_format_float" (* Stolen from [pervasives.ml]. Adds a "." at the end if needed. It is in [pervasives.mli], but it also says not to use it directly, so we copy and paste the code. It makes the assumption on the string passed in argument that it was returned by [format_float] *) let valid_float_lexem s = let l = String.length s in let rec loop i = if i >= l then s ^ "." else match s.[i] with | '0' .. '9' | '-' -> loop (i + 1) | _ -> s in loop 0 ;; (* Standard 12 significant digits, exponential notation used as necessary, guaranteed to be a valid OCaml float lexem, not to look like an int. *) let to_string x = valid_float_lexem (format_float "%.12g" x);; (* Let [y] be a power of 2. Then the next representable float is: [z = y * (1 + 2 ** -52)] and the previous one is [x = y * (1 - 2 ** -53)] In general, every two adjacent floats are within a factor of between [1 + 2**-53] and [1 + 2**-52] from each other, that is within [1 + 1.1e-16] and [1 + 2.3e-16]. So if the decimal representation of a float starts with "1", then its adjacent floats will usually differ from it by 1, and sometimes by 2, at the 17th significant digit (counting from 1). On the other hand, if the decimal representation starts with "9", then the adjacent floats will be off by no more than 23 at the 16th and 17th significant digits. E.g.: # sprintf "%.17g" (1024. *. (1. -. 2.** (-53.)));; 11111111 1234 5678901234567 - : string = "1023.9999999999999" Printing a couple of extra digits reveals that the difference indeed is roughly 11 at digits 17th and 18th (that is, 13th and 14th after "."): # sprintf "%.19g" (1024. *. (1. -. 2.** (-53.)));; 1111111111 1234 567890123456789 - : string = "1023.999999999999886" The ulp (the difference between adjacent floats) is twice as big on the other side of 1024.: # sprintf "%.19g" (1024. *. (1. +. 2.** (-52.)));; 1111111111 1234 567890123456789 - : string = "1024.000000000000227" Now take a power of 2 which starts with 99: # 2.**93. ;; 1111111111 1 23456789012345678 - : float = 9.9035203142830422e+27 # 2.**93. *. (1. +. 2.** (-52.));; - : float = 9.9035203142830444e+27 # 2.**93. *. (1. -. 2.** (-53.));; - : float = 9.9035203142830411e+27 The difference between 2**93 and its two neighbors is slightly more than, respectively, 1 and 2 at significant digit 16. Those examples show that: - 17 significant digits is always sufficient to represent a float without ambiguity - 15th significant digit can always be represented accurately - converting a decimal number with 16 significant digits to its nearest float and back can change the last decimal digit by no more than 1 To make sure that floats obtained by conversion from decimal fractions (e.g. "3.14") are printed without trailing non-zero digits, one should choose the first among the '%.15g', '%.16g', and '%.17g' representations which does round-trip: # sprintf "%.15g" 3.14;; - : string = "3.14" (* pick this one *) # sprintf "%.16g" 3.14;; - : string = "3.14" # sprintf "%.17g" 3.14;; - : string = "3.1400000000000001" (* do not pick this one *) # sprintf "%.15g" 8.000000000000002;; - : string = "8" (* do not pick this one--does not round-trip *) # sprintf "%.16g" 8.000000000000002;; - : string = "8.000000000000002" (* prefer this one *) # sprintf "%.17g" 8.000000000000002;; - : string = "8.0000000000000018" (* this one has one digit of junk at the end *) Skipping the '%.16g' in the above procedure saves us some time, but it means that, as seen in the second example above, occasionally numbers with exactly 16 significant digits will have an error introduced at the 17th digit. That is probably OK for typical use, because a number with 16 significant digits is "ugly" already. Adding one more doesn't make it much worse for a human reader. On the other hand, we cannot skip '%.15g' and only look at '%.16g' and '%.17g', since the inaccuracy at the 16th digit might introduce the noise we want to avoid: # sprintf "%.15g" 9.992;; - : string = "9.992" (* pick this one *) # sprintf "%.16g" 9.992;; - : string = "9.992000000000001" (* do not pick this one--junk at the end *) # sprintf "%.17g" 9.992;; - : string = "9.9920000000000009" *) let to_string_round_trippable x = valid_float_lexem ( let y = format_float "%.15g" x in if float_of_string y = x then y else format_float "%.17g" x) ;; let nan = Pervasives.nan let infinity = Pervasives.infinity let neg_infinity = Pervasives.neg_infinity let max_value = infinity let min_value = neg_infinity let max_finite_value = Pervasives.max_float let min_positive_subnormal_value = 2. ** -1074. let min_positive_normal_value = 2. ** -1022. let is_nan x = (x : t) <> x (* An order-preserving bijection between all floats except for NaNs, and 99.95% of int64s. Note we don't distinguish 0. and -0. as separate values here, they both map to 0L, which maps back to 0. This should work both on little-endian and high-endian CPUs. Wikipedia says: "on modern standard computers (i.e., implementing IEEE 754), one may in practice safely assume that the endianness is the same for floating point numbers as for integers" (http://en.wikipedia.org/wiki/Endianness#Floating-point_and_endianness). *) let to_int64_preserve_order t = if is_nan t then None else if t = 0. then (* also includes -0. *) Some 0L else if t > 0. then Some (Int64.bits_of_float t) else Some (Int64.neg (Int64.bits_of_float (~-. t))) ;; let to_int64_preserve_order_exn x = Option.value_exn (to_int64_preserve_order x) ;; let of_int64_preserve_order x = if x >= 0L then Int64.float_of_bits x else ~-. (Int64.float_of_bits (Int64.neg x)) ;; let one_ulp dir t = match to_int64_preserve_order t with | None -> nan | Some x -> of_int64_preserve_order (Int64.add x (match dir with `Up -> 1L | `Down -> -1L)) ;; TEST_MODULE = struct let test_both_ways a b = to_int64_preserve_order_exn a = b && of_int64_preserve_order b = a ;; TEST = test_both_ways 0. 0L TEST = test_both_ways (-0.) 0L TEST = test_both_ways 1. Int64.(shift_left 1023L 52) TEST = test_both_ways (-2.) Int64.(neg (shift_left 1024L 52)) TEST = test_both_ways infinity Int64.(shift_left 2047L 52) TEST = test_both_ways neg_infinity Int64.(neg (shift_left 2047L 52)) TEST = one_ulp `Down infinity = max_finite_value TEST = is_nan (one_ulp `Up infinity) TEST = is_nan (one_ulp `Down neg_infinity) TEST = one_ulp `Up neg_infinity = ~-. max_finite_value (* Some tests to make sure that the compiler is generating code for handling subnormal numbers at runtime accurately. *) let x () = min_positive_subnormal_value let y () = min_positive_normal_value TEST = test_both_ways (x ()) 1L TEST = test_both_ways (y ()) Int64.(shift_left 1L 52) TEST = x () > 0. TEST_UNIT = <:test_result> (x () /. 2.) ~expect:0. TEST = one_ulp `Up 0. = x () TEST = one_ulp `Down 0. = ~-. (x ()) let are_one_ulp_apart a b = one_ulp `Up a = b TEST = are_one_ulp_apart (x ()) (2. *. x ()) TEST = are_one_ulp_apart (2. *. x ()) (3. *. x ()) let one_ulp_below_y () = y () -. x () TEST = one_ulp_below_y () < y () TEST = y () -. one_ulp_below_y () = x () TEST = are_one_ulp_apart (one_ulp_below_y ()) (y ()) let one_ulp_above_y () = y () +. x () TEST = y () < one_ulp_above_y () TEST = one_ulp_above_y () -. y () = x () TEST = are_one_ulp_apart (y ()) (one_ulp_above_y ()) TEST = not (are_one_ulp_apart (one_ulp_below_y ()) (one_ulp_above_y ())) (* [2 * min_positive_normal_value] is where the ulp increases for the first time. *) let z () = 2. *. y () let one_ulp_below_z () = z () -. x () TEST = one_ulp_below_z () < z () TEST = z () -. one_ulp_below_z () = x () TEST = are_one_ulp_apart (one_ulp_below_z ()) (z ()) let one_ulp_above_z () = z () +. 2. *. x () TEST = z () < one_ulp_above_z () TEST = one_ulp_above_z () -. z () = 2. *. x () TEST = are_one_ulp_apart (z ()) (one_ulp_above_z ()) end let zero = 0. let one = 1. let minus_one = -1. TEST = to_string_round_trippable 3.14 = "3.14" TEST = to_string_round_trippable 3.1400000000000001 = "3.14" TEST = to_string_round_trippable 3.1400000000000004 = "3.1400000000000006" TEST = to_string_round_trippable 8.000000000000002 = "8.0000000000000018" TEST = to_string_round_trippable 9.992 = "9.992" TEST = to_string_round_trippable (2.**63. *. (1. +. 2.** (-52.))) = "9.2233720368547779e+18" TEST = to_string_round_trippable (-3.) = "-3." TEST = to_string_round_trippable nan = "nan" TEST = to_string_round_trippable infinity = "inf" TEST = to_string_round_trippable neg_infinity = "-inf" TEST = to_string_round_trippable 3e100 = "3e+100" TEST = to_string_round_trippable max_finite_value = "1.7976931348623157e+308" TEST = to_string_round_trippable min_positive_subnormal_value = "4.94065645841247e-324" let frexp = Pervasives.frexp let ldexp = Pervasives.ldexp module Robustly_comparable = Float_robust_compare.Make (struct let robust_comparison_tolerance = 1E-7 end) include Robustly_comparable let epsilon_float = Pervasives.epsilon_float TEST = epsilon_float = (one_ulp `Up 1.) -. 1. include Hashable.Make_binable (T) let of_int = Core_int.to_float let to_int = Core_int.of_float let of_int64 i = Int64.to_float i let to_int64 f = let module P = Pervasives in match P.classify_float f with | P.FP_normal | P.FP_subnormal | P.FP_zero -> Int64.of_float f | P.FP_infinite | P.FP_nan -> invalid_arg "Float.to_int64 on nan or inf" (* max_int/min_int are architecture dependent, e.g. +/- 2^30, +/- 2^62 if 32-bit, 64-bit (respectively) while float is IEEE standard for double (52 significant bits). In both cases, we want to guarantee that if [iround_lbound <= x <= iround_ubound], then [int_of_float x] fits in an int. 2.0 ** 62.0 -. 512. is the greatest representable double <= max_int on a 64-bit box, so we choose that for the upper bound. For the lower bound, [min_int] is already representable, so we use that. Minor point: [iround_lbound] and [iround_ubound] are integers (in the mathematical sense), so if [iround_lbound <= t <= iround_ubound], then [iround_lbound <= floor t <= ceil t <= iround_ubound]. *) let iround_lbound = of_int min_int let iround_ubound = min (of_int max_int) (2.0 ** 62.0 -. 512.) (* The performance of the "exn" rounding functions is important, so they are written out separately, and tuned individually. (We could have the option versions call the "exn" versions, but that imposes arguably gratuitous overhead---especially in the case where the capture of backtraces is enabled upon "with"---and that seems not worth it when compared to the relatively small amount of code duplication.) *) (* Error reporting below is very carefully arranged so that, e.g., [iround_nearest_exn] itself can be inlined into callers such that they don't need to allocate a box for the [float] argument. This is done with a [box] function carefully chosen to allow the compiler to create a separate box for the float only in error cases. *) let box = (* Prevent potential constant folding of [+. 0.] in the near ocamlopt future. *) let x = if Random.bool () then 0. else 0. in (fun f -> f +. x) let iround_up t = if t > 0.0 then begin if t <= iround_ubound then Some (int_of_float (ceil t)) else None end else begin if t >= iround_lbound then Some (int_of_float t) else None end let iround_up_exn t = if t > 0.0 then begin if t <= iround_ubound then int_of_float (ceil t) else invalid_argf "Float.iround_up_exn: argument (%f) is too large" (box t) () end else begin if t >= iround_lbound then int_of_float t else invalid_argf "Float.iround_up_exn: argument (%f) is too small or NaN" (box t) () end let iround_down t = if t >= 0.0 then begin if t <= iround_ubound then Some (int_of_float t) else None end else begin if t >= iround_lbound then Some (int_of_float (floor t)) else None end let iround_down_exn t = if t >= 0.0 then begin if t <= iround_ubound then int_of_float t else invalid_argf "Float.iround_down_exn: argument (%f) is too large" (box t) () end else begin if t >= iround_lbound then int_of_float (floor t) else invalid_argf "Float.iround_down_exn: argument (%f) is too small or NaN" (box t) () end let iround_towards_zero t = if t >= iround_lbound && t <= iround_ubound then Some (int_of_float t) else None let iround_towards_zero_exn t = if t >= iround_lbound && t <= iround_ubound then int_of_float t else invalid_argf "Float.iround_towards_zero_exn: argument (%f) is out of range or NaN" (box t) () (* Outside of the range [round_nearest_lb..round_nearest_ub], all representable doubles are integers in the mathematical sense, and [round_nearest] should be identity. However, for odd numbers with the absolute value between 2**52 and 2**53, the formula [round_nearest x = floor (x + 0.5)] does not hold: # let naive_round_nearest x = floor (x +. 0.5);; # let x = 2. ** 52. +. 1.;; val x : float = 4503599627370497. # naive_round_nearest x;; - : float = 4503599627370498. *) IFDEF ARCH_SIXTYFOUR THEN let round_nearest_lb = -.(2. ** 52.) let round_nearest_ub = 2. ** 52. ELSE let int_size_minus_one = float_of_int (Core_int.num_bits - 1) let round_nearest_lb = -.(2. ** int_size_minus_one) let round_nearest_ub = (2. ** int_size_minus_one) -. 1. ENDIF let iround_nearest t = if t >= 0. then if t <= round_nearest_ub then Some (int_of_float (t +. 0.5)) else if t <= iround_ubound then Some (int_of_float t) else None else if t >= round_nearest_lb then Some (int_of_float (floor (t +. 0.5))) else if t >= iround_lbound then Some (int_of_float t) else None let iround_nearest_exn t = if t >= 0. then if t <= round_nearest_ub then int_of_float (t +. 0.5) else if t <= iround_ubound then int_of_float t else invalid_argf "Float.iround_nearest_exn: argument (%f) is too large" (box t) () else if t >= round_nearest_lb then int_of_float (floor (t +. 0.5)) else if t >= iround_lbound then int_of_float t else invalid_argf "Float.iround_nearest_exn: argument (%f) is too small or NaN" (box t) () (* The following [iround_exn] and [iround] functions are slower than the ones above. Their equivalence to those functions is tested in the unit tests below. *) let iround_exn ?(dir=`Nearest) t = match dir with | `Zero -> iround_towards_zero_exn t | `Nearest -> iround_nearest_exn t | `Up -> iround_up_exn t | `Down -> iround_down_exn t let iround ?(dir=`Nearest) t = try Some (iround_exn ~dir t) with _ -> None let is_inf x = (Pervasives.classify_float x = Pervasives.FP_infinite);; let min_inan (x : t) y = if is_nan y then x else if is_nan x then y else if x < y then x else y let max_inan (x : t) y = if is_nan y then x else if is_nan x then y else if x > y then x else y let add = (+.) let sub = (-.) let neg = (~-.) let abs = Pervasives.abs_float let scale = ( *. ) let min (x : t) y = if is_nan x || is_nan y then nan else if x < y then x else y let max (x : t) y = if is_nan x || is_nan y then nan else if x > y then x else y module Parts : sig type t val fractional : t -> float val integral : t -> float val modf : float -> t end = struct type t = float * float let fractional t = fst t let integral t = snd t let modf = modf end let modf = Parts.modf let round_down = floor TEST = round_down 3.6 = 3. && round_down (-3.6) = -4. let round_up = ceil TEST = round_up 3.6 = 4. && round_up (-3.6) = -3. let round_towards_zero t = if t >= 0. then round_down t else round_up t TEST = round_towards_zero 3.6 = 3. && round_towards_zero (-3.6) = -3. (* see the comment above [round_nearest_lb] and [round_nearest_ub] for an explanation *) let round_nearest t = if t >= round_nearest_lb && t <= round_nearest_ub then floor (t +. 0.5) else t (* See [iround_lbound] and [iround_ubound] for more explanation. *) let int63_round_lbound = ~-. (2. ** 62.) let int63_round_ubound = 2.0 ** 62.0 -. 512. let int63_round_nearest_portable_alloc_exn t = if t > 0. then begin if t <= int63_round_ubound then Core_int63.of_float (round_nearest t) else invalid_argf "Float.int63_round_nearest_portable_alloc_exn: argument (%f) is too large" t () end else begin if t >= int63_round_lbound then Core_int63.of_float (round_nearest t) else invalid_argf "Float.int63_round_nearest_portable_alloc_exn: argument (%f) is too small or NaN" t () end TEST_MODULE = struct (* check we raise on invalid input *) let must_fail f x = try ignore (f x); false with _ -> true let must_succeed f x = try ignore (f x); true with err -> print_endline (Exn.to_string err); false TEST = must_fail int63_round_nearest_portable_alloc_exn nan TEST = must_fail int63_round_nearest_portable_alloc_exn max_value TEST = must_fail int63_round_nearest_portable_alloc_exn min_value TEST = must_fail int63_round_nearest_portable_alloc_exn (2. ** 63.) TEST = must_fail int63_round_nearest_portable_alloc_exn (~-. (2. ** 63.)) TEST = must_succeed int63_round_nearest_portable_alloc_exn (2. ** 62. -. 512.) TEST = must_fail int63_round_nearest_portable_alloc_exn (2. ** 62.) TEST = must_fail int63_round_nearest_portable_alloc_exn (~-. (2. ** 62.) -. 1024.) TEST = must_succeed int63_round_nearest_portable_alloc_exn (~-. (2. ** 62.)) end let int63_round_nearest_arch64_noalloc_exn f = Core_int63.of_int (iround_nearest_exn f) IFDEF ARCH_SIXTYFOUR THEN let int63_round_nearest_exn = int63_round_nearest_arch64_noalloc_exn TEST = let before = Core_gc.minor_words () in assert (int63_round_nearest_exn 0.8 = Core_int63.of_int_exn 1); let after = Core_gc.minor_words () in before = after ELSE let int63_round_nearest_exn = int63_round_nearest_portable_alloc_exn ENDIF BENCH_MODULE "round_nearest portability/performance" = struct let f = if Random.bool () then 1.0 else 2.0 BENCH "int63_round_nearest_portable_alloc_exn" = int63_round_nearest_portable_alloc_exn f BENCH "int63_round_nearest_arch64_noalloc_exn" = int63_round_nearest_arch64_noalloc_exn f BENCH "int63_round_nearest_exn" = int63_round_nearest_exn f (* Here is a comparison of both of these rounding operators on a 64-bit machine. Hence we have special-cased this so that we get the faster operation on 64-bit machines. We also benchmark the selected operator to make sure we actually select the right one ┌────────────────────────────────────────┬──────────┬─────────┬────────────┠│ Name │ Time/Run │ mWd/Run │ Percentage │ ├────────────────────────────────────────┼──────────┼─────────┼────────────┤ │ int63_round_nearest_portable_alloc_exn │ 18.41ns │ 2.00w │ 100.00% │ │ int63_round_nearest_arch64_noalloc_exn │ 4.27ns │ │ 23.17% │ │ int63_round_nearest_exn │ 4.27ns │ │ 23.18% │ └────────────────────────────────────────┴──────────┴─────────┴────────────┘ *) end TEST = round_nearest 3.6 = 4. && round_nearest (-3.6) = -4. TEST = let before = Core_gc.minor_words () in assert(round_nearest 3.6 = 4.); let after = Core_gc.minor_words () in before = after let round ?(dir=`Nearest) t = match dir with | `Nearest -> round_nearest t | `Down -> round_down t | `Up -> round_up t | `Zero -> round_towards_zero t let mod_float = Pervasives.mod_float module Class = struct type t = | Infinite | Nan | Normal | Subnormal | Zero with sexp, bin_io let to_string t = Sexp.to_string (sexp_of_t t) let of_string s = t_of_sexp (Sexp.Atom s) end let classify t = let module C = Class in let module P = Pervasives in match P.classify_float t with | P.FP_normal -> C.Normal | P.FP_subnormal -> C.Subnormal | P.FP_zero -> C.Zero | P.FP_infinite -> C.Infinite | P.FP_nan -> C.Nan ;; let is_finite t = let module C = Class in match classify t with | C.Normal | C.Subnormal | C.Zero -> true | C.Infinite | C.Nan -> false let to_string_hum ?(delimiter='_') ?(decimals=3) ?(strip_zero=false) f = if decimals < 0 then invalid_argf "to_string_hum: invalid argument ~decimals=%d" decimals (); match classify f with | Class.Infinite -> if f >. 0. then "inf" else "-inf" | Class.Nan -> "nan" | Class.Normal | Class.Subnormal | Class.Zero -> let sprintf_result = sprintf "%.*f" decimals f in match String.lsplit2 sprintf_result ~on:'.' with | None -> assert (decimals = 0); Int_conversions.insert_delimiter sprintf_result ~delimiter | Some (left, right) -> let left = Int_conversions.insert_delimiter left ~delimiter in let right = if strip_zero then String.rstrip right ~drop:(fun c -> c = '0') else right in match right with | "" -> left | _ -> left ^ "." ^ right ;; TEST_MODULE = struct let test ?delimiter ~decimals f s s_strip_zero = let s' = to_string_hum ?delimiter ~decimals ~strip_zero:false f in if s' <> s then failwiths "to_string_hum ~strip_zero:false" (`input f, `decimals decimals, `got s', `expected s) (<:sexp_of< ([ `input of float ] * [ `decimals of int ] * [ `got of string ] * [ `expected of string ]) >>); let s_strip_zero' = to_string_hum ?delimiter ~decimals ~strip_zero:true f in if s_strip_zero' <> s_strip_zero then failwiths "to_string_hum ~strip_zero:true" (`input f, `decimals decimals, `got s_strip_zero, `expected s_strip_zero') (<:sexp_of< ([ `input of float ] * [ `decimals of int ] * [ `got of string ] * [ `expected of string ]) >>); ;; TEST_UNIT = test ~decimals:3 0.99999 "1.000" "1" TEST_UNIT = test ~decimals:3 0.00001 "0.000" "0" TEST_UNIT = test ~decimals:3 ~-.12345.1 "-12_345.100" "-12_345.1" TEST_UNIT = test ~delimiter:',' ~decimals:3 ~-.12345.1 "-12,345.100" "-12,345.1" TEST_UNIT = test ~decimals:0 0.99999 "1" "1" TEST_UNIT = test ~decimals:0 0.00001 "0" "0" TEST_UNIT = test ~decimals:0 ~-.12345.1 "-12_345" "-12_345" TEST_UNIT = test ~decimals:0 (5.0 /. 0.0) "inf" "inf" TEST_UNIT = test ~decimals:0 (-5.0 /. 0.0) "-inf" "-inf" TEST_UNIT = test ~decimals:0 (0.0 /. 0.0) "nan" "nan" TEST_UNIT = test ~decimals:2 (5.0 /. 0.0) "inf" "inf" TEST_UNIT = test ~decimals:2 (-5.0 /. 0.0) "-inf" "-inf" TEST_UNIT = test ~decimals:2 (0.0 /. 0.0) "nan" "nan" TEST_UNIT = test ~decimals:5 (10_000.0 /. 3.0) "3_333.33333" "3_333.33333" TEST_UNIT = test ~decimals:2 ~-.0.00001 "-0.00" "-0" let rand_test n = let go () = let f = Random.float 1_000_000.0 -. 500_000.0 in let repeatable to_str = let s = to_str f in if (String.split s ~on:',' |! String.concat |! of_string |! to_str) <> s then failwithf "failed on testing %f" f () in repeatable (to_string_hum ~decimals:3 ~strip_zero:false); in try for _i = 0 to n - 1 do go () done; true with e -> Printf.eprintf "%s\n%!" (Exn.to_string e); false ;; TEST = rand_test 10_000 ;; end ;; let to_padded_compact_string t = (* Round a ratio toward the nearest integer, resolving ties toward the nearest even number. For sane inputs (in particular, when [denominator] is an integer and [abs numerator < 2e52]) this should be accurate. Otherwise, the result might be a little bit off, but we don't really use that case. *) let iround_ratio_exn ~numerator ~denominator = let k = floor (numerator /. denominator) in (* if [abs k < 2e53], then both [k] and [k +. 1.] are accurately represented, and in particular [k +. 1. > k]. If [denominator] is also an integer, and [abs (denominator *. (k +. 1)) < 2e53] (and in some other cases, too), then [lower] and [higher] are actually both accurate. Since (roughly) [numerator = denominator *. k] then for [abs numerator < 2e52] we should be fine. *) let lower = denominator *. k in let higher = denominator *. (k +. 1.) in (* Subtracting numbers within a factor of two from each other is accurate. So either the two subtractions below are accurate, or k = 0, or k = -1. In case of a tie, round to even. *) let diff_right = higher -. numerator in let diff_left = numerator -. lower in let k = iround_nearest_exn k in if diff_right < diff_left then k + 1 else if diff_right > diff_left then k else (* a tie *) if k mod 2 = 0 then k else k + 1 in match classify t with | Class.Infinite -> if t < 0.0 then "-inf " else "inf " | Class.Nan -> "nan " | Class.Subnormal | Class.Normal | Class.Zero -> let go t = let conv_one t = assert (0. <= t && t < 999.95); let x = format_float "%.1f" t in (* Fix the ".0" suffix *) if String.is_suffix x ~suffix:".0" then begin let n = String.length x in x.[n - 1] <- ' '; x.[n - 2] <- ' '; end; x in let conv mag t denominator = assert (denominator = 100. && t >= 999.95 || denominator >= 100_000. && t >= round_nearest (denominator *. 9.999_5)); assert (t < round_nearest (denominator *. 9_999.5)); let i, d = let k = iround_ratio_exn ~numerator:t ~denominator in (* [mod] is okay here because we know i >= 0. *) k / 10, k mod 10 in assert (0 <= i && i < 1000); assert (0 <= d && d < 10); if d = 0 then sprintf "%d%c " i mag else sprintf "%d%c%d" i mag d in (* While the standard metric prefixes (e.g. capital "M" rather than "m", [1]) are nominally more correct, this hinders readability in our case. E.g., 10G6 and 1066 look too similar. That's an extreme example, but in general k,m,g,t,p probably stand out better than K,M,G,T,P when interspersed with digits. [1] http://en.wikipedia.org/wiki/Metric_prefix *) (* The trick here is that: - the first boundary (999.95) as a float is slightly over-represented (so it is better approximated as "1k" than as "999.9"), - the other boundaries are accurately represented, because they are integers. That's why the strict equalities below do exactly what we want. *) if t < 999.95E0 then conv_one t else if t < 999.95E3 then conv 'k' t 100. else if t < 999.95E6 then conv 'm' t 100_000. else if t < 999.95E9 then conv 'g' t 100_000_000. else if t < 999.95E12 then conv 't' t 100_000_000_000. else if t < 999.95E15 then conv 'p' t 100_000_000_000_000. else sprintf "%.1e" t in if t >= 0. then go t else "-" ^ (go ~-.t) TEST_MODULE = struct let test f expect = let actual = to_padded_compact_string f in if actual <> expect then failwithf "%f: expected '%s', got '%s'" f expect actual () let both f expect = assert (f > 0.); test f expect; test (~-.f) ("-"^expect); ;; let decr = one_ulp `Down let incr = one_ulp `Up let boundary f ~closer_to_zero ~at = assert (f > 0.); (* If [f] looks like an odd multiple of 0.05, it might be slightly under-represented as a float, e.g. 1. -. 0.95 = 0.0500000000000000444 In such case, sadly, the right way for [to_padded_compact_string], just as for [sprintf "%.1f"], is to round it down. However, the next representable number should be rounded up: # let x = 0.95 in sprintf "%.0f / %.1f / %.2f / %.3f / %.20f" x x x x x;; - : string = "1 / 0.9 / 0.95 / 0.950 / 0.94999999999999995559" # let x = incr 0.95 in sprintf "%.0f / %.1f / %.2f / %.3f / %.20f" x x x x x ;; - : string = "1 / 1.0 / 0.95 / 0.950 / 0.95000000000000006661" *) let f = if f >= 1000. then f else let x = sprintf "%.20f" f in let spot = String.index_exn x '.' in (* the following condition is only meant to work for small multiples of 0.05 *) if x.[spot + 2] = '4' && x.[spot + 3] = '9' && x.[spot + 4] = '9' then (* something like 0.94999999999999995559 *) incr f else f in both (decr f) closer_to_zero; both f at; ;; TEST_UNIT = test nan "nan "; TEST_UNIT = test 0.0 "0 "; TEST_UNIT = both min_positive_subnormal_value "0 "; TEST_UNIT = both infinity "inf "; TEST_UNIT = boundary 0.05 ~closer_to_zero: "0 " ~at: "0.1"; TEST_UNIT = boundary 0.15 ~closer_to_zero: "0.1" ~at: "0.2"; (* glibc printf resolves ties to even, cf. http://www.exploringbinary.com/inconsistent-rounding-of-printed-floating-point-numbers/ *) TEST_UNIT = boundary (* tie *) 0.25 ~closer_to_zero: "0.2" ~at: "0.2"; TEST_UNIT = boundary (incr 0.25)~closer_to_zero: "0.2" ~at: "0.3"; TEST_UNIT = boundary 0.35 ~closer_to_zero: "0.3" ~at: "0.4"; TEST_UNIT = boundary 0.45 ~closer_to_zero: "0.4" ~at: "0.5"; TEST_UNIT = both 0.50 "0.5"; TEST_UNIT = boundary 0.55 ~closer_to_zero: "0.5" ~at: "0.6"; TEST_UNIT = boundary 0.65 ~closer_to_zero: "0.6" ~at: "0.7"; (* this time tie-to-even means round away from 0 *) TEST_UNIT = boundary (* tie *) 0.75 ~closer_to_zero: "0.7" ~at: "0.8"; TEST_UNIT = boundary 0.85 ~closer_to_zero: "0.8" ~at: "0.9"; TEST_UNIT = boundary 0.95 ~closer_to_zero: "0.9" ~at: "1 "; TEST_UNIT = boundary 1.05 ~closer_to_zero: "1 " ~at: "1.1"; TEST_UNIT = boundary 3.25 ~closer_to_zero: "3.2" ~at: "3.2"; TEST_UNIT = boundary (incr 3.25)~closer_to_zero: "3.2" ~at: "3.3"; TEST_UNIT = boundary 3.75 ~closer_to_zero: "3.7" ~at: "3.8"; TEST_UNIT = boundary 9.95 ~closer_to_zero: "9.9" ~at: "10 "; TEST_UNIT = boundary 10.05 ~closer_to_zero: "10 " ~at: "10.1"; TEST_UNIT = boundary 100.05 ~closer_to_zero:"100 " ~at: "100.1"; TEST_UNIT = boundary (* tie *) 999.25 ~closer_to_zero:"999.2" ~at: "999.2"; TEST_UNIT = boundary (incr 999.25)~closer_to_zero:"999.2" ~at: "999.3"; TEST_UNIT = boundary 999.75 ~closer_to_zero:"999.7" ~at: "999.8"; TEST_UNIT = boundary 999.95 ~closer_to_zero:"999.9" ~at: "1k "; TEST_UNIT = both 1000. "1k "; (* some ties which we resolve manually in [iround_ratio_exn] *) TEST_UNIT = boundary 1050. ~closer_to_zero: "1k " ~at: "1k " TEST_UNIT = boundary (incr 1050.) ~closer_to_zero: "1k " ~at: "1k1" TEST_UNIT = boundary 1950. ~closer_to_zero: "1k9" ~at: "2k "; TEST_UNIT = boundary 3250. ~closer_to_zero: "3k2" ~at: "3k2"; TEST_UNIT = boundary (incr 3250.) ~closer_to_zero: "3k2" ~at: "3k3"; TEST_UNIT = boundary 9950. ~closer_to_zero: "9k9" ~at: "10k "; TEST_UNIT = boundary 33_250. ~closer_to_zero: "33k2" ~at: "33k2"; TEST_UNIT = boundary (incr 33_250.) ~closer_to_zero: "33k2" ~at: "33k3"; TEST_UNIT = boundary 33_350. ~closer_to_zero: "33k3" ~at: "33k4"; TEST_UNIT = boundary 33_750. ~closer_to_zero: "33k7" ~at: "33k8"; TEST_UNIT = boundary 333_250. ~closer_to_zero:"333k2" ~at: "333k2"; TEST_UNIT = boundary (incr 333_250.) ~closer_to_zero:"333k2" ~at: "333k3"; TEST_UNIT = boundary 333_750. ~closer_to_zero:"333k7" ~at: "333k8"; TEST_UNIT = boundary 999_850. ~closer_to_zero:"999k8" ~at: "999k8"; TEST_UNIT = boundary (incr 999_850.) ~closer_to_zero:"999k8" ~at: "999k9"; TEST_UNIT = boundary 999_950. ~closer_to_zero:"999k9" ~at: "1m "; TEST_UNIT = boundary 1_050_000. ~closer_to_zero: "1m " ~at: "1m "; TEST_UNIT = boundary (incr 1_050_000.) ~closer_to_zero: "1m " ~at: "1m1"; TEST_UNIT = boundary 999_950_000. ~closer_to_zero:"999m9" ~at: "1g "; TEST_UNIT = boundary 999_950_000_000. ~closer_to_zero:"999g9" ~at: "1t "; TEST_UNIT = boundary 999_950_000_000_000. ~closer_to_zero:"999t9" ~at: "1p "; TEST_UNIT = boundary 999_950_000_000_000_000. ~closer_to_zero:"999p9" ~at:"1.0e+18"; (* Test the boundary between the subnormals and the normals. *) TEST_UNIT = boundary min_positive_normal_value ~closer_to_zero:"0 " ~at:"0 "; end module Replace_polymorphic_compare = struct let equal = equal let compare (x : t) y = compare x y let ascending = compare let descending x y = compare y x let min = min let max = max let ( >= ) (x : t) y = x >= y let ( <= ) (x : t) y = x <= y let ( = ) (x : t) y = x = y let ( > ) (x : t) y = x > y let ( < ) (x : t) y = x < y let ( <> ) (x : t) y = x <> y let between t ~low ~high = low <= t && t <= high let _squelch_unused_module_warning_ = () end include Replace_polymorphic_compare let ( + ) = ( +. ) let ( - ) = ( -. ) let ( * ) = ( *. ) let ( / ) = ( /. ) let ( ~- ) = ( ~-. ) include Comparable.Map_and_set_binable (T) module Sign = struct type t = Neg | Zero | Pos with sexp end let sign t = if t >. 0. then Sign.Pos else if t <. 0. then Sign.Neg else Sign.Zero let ieee_negative t = let bits = Int64.bits_of_float t in Pervasives.(bits < Int64.zero) let exponent_bits = 11 let mantissa_bits = 52 let exponent_mask64 = Core_int64.((shift_left one exponent_bits) - one) let exponent_mask = Core_int64.to_int_exn exponent_mask64 let mantissa_mask = Core_int63.((shift_left one mantissa_bits) - one) let mantissa_mask64 = Core_int63.to_int64 mantissa_mask let ieee_exponent t = let bits = Int64.bits_of_float t in Core_int64.((bit_and (shift_right_logical bits mantissa_bits) exponent_mask64)) |> Int64.to_int let ieee_mantissa t = let bits = Int64.bits_of_float t in Core_int63.of_int64_exn Int64.(logand bits mantissa_mask64) let create_ieee_exn ~negative ~exponent ~mantissa = if Core_int.(bit_and exponent exponent_mask <> exponent) then failwithf !"exponent %{Core_int} out of range [0, %{Core_int}]" exponent exponent_mask () else if Core_int63.(bit_and mantissa mantissa_mask <> mantissa) then failwithf !"mantissa %{Core_int63} out of range [0, %{Core_int63}]" mantissa mantissa_mask () else let sign_bits = if negative then Int64.min_int else Int64.zero in let expt_bits = Int64.shift_left (Int64.of_int exponent) mantissa_bits in let mant_bits = Core_int63.to_int64 mantissa in let bits = Int64.(logor sign_bits (logor expt_bits mant_bits)) in Int64.float_of_bits bits let create_ieee ~negative ~exponent ~mantissa = Or_error.try_with (fun () -> create_ieee_exn ~negative ~exponent ~mantissa) TEST_MODULE "IEEE" = struct (* Note: IEEE 754 defines NaN values to be those where the exponent is all 1s and the mantissa is nonzero. test_result sees nan values as equal because it is based on [compare] rather than [=]. (If [x] and [x'] are nan, [compare x x'] returns 0, whereas [x = x'] returns [false]. This is the case regardless of whether or not [x] and [x'] are bit-identical values of nan.) *) let f (t : t) (negative : bool) (exponent : int) (mantissa : Core_int63.t) : unit = let str = to_string_round_trippable t in let is_nan = is_nan t in (* the sign doesn't matter when nan *) if not is_nan then <:test_result> ~message:("ieee_negative " ^ str) (ieee_negative t) ~expect:negative; <:test_result> ~message:("ieee_exponent " ^ str) (ieee_exponent t) ~expect:exponent; if is_nan then assert (Core_int63.(zero <> ieee_mantissa t)) else <:test_result> ~message:("ieee_mantissa " ^ str) (ieee_mantissa t) ~expect:mantissa; <:test_result> ~message:(sprintf !"create_ieee ~negative:%B ~exponent:%d ~mantissa:%{Core_int63}" negative exponent mantissa) (create_ieee_exn ~negative ~exponent ~mantissa) ~expect:t TEST_UNIT = let (!!) x = Core_int63.of_int x in f zero false 0 (!! 0); f min_positive_subnormal_value false 0 (!! 1); f min_positive_normal_value false 1 (!! 0); f epsilon_float false Pervasives.(1023 - mantissa_bits) (!! 0); f one false 1023 (!! 0); f minus_one true 1023 (!! 0); f max_finite_value false Pervasives.(exponent_mask - 1) mantissa_mask; f infinity false exponent_mask (!! 0); f neg_infinity true exponent_mask (!! 0); f nan false exponent_mask (!! 1) (* test the normalized case, that is, 1 <= exponent <= 2046 *) TEST_UNIT = let g ~negative ~exponent ~mantissa = assert (create_ieee_exn ~negative ~exponent ~mantissa:(Core_int63.of_int64_exn mantissa) = (if negative then -1. else 1.) * 2. ** (float exponent - 1023.) * (1. + (2. ** -52.) * Int64.to_float mantissa)) in g ~negative:false ~exponent:1 ~mantissa:147L; g ~negative:true ~exponent:137 ~mantissa:13L; g ~negative:false ~exponent:1015 ~mantissa:1370001L; g ~negative:true ~exponent:2046 ~mantissa:137000100945L; end module Terse = struct type t = outer with bin_io let t_of_sexp = t_of_sexp let to_string x = Core_printf.sprintf "%.8G" x let sexp_of_t x = Sexp.Atom (to_string x) let of_string x = of_string x end let validate_ordinary t = Validate.of_error_opt ( let module C = Class in match classify t with | C.Normal | C.Subnormal | C.Zero -> None | C.Infinite -> Some "value is infinite" | C.Nan -> Some "value is NaN") ;; module V = struct module ZZ = Comparable.Validate (T) let validate_bound ~min ~max t = Validate.first_failure (validate_ordinary t) (ZZ.validate_bound t ~min ~max) ;; let validate_lbound ~min t = Validate.first_failure (validate_ordinary t) (ZZ.validate_lbound t ~min) ;; let validate_ubound ~max t = Validate.first_failure (validate_ordinary t) (ZZ.validate_ubound t ~max) ;; end include V include Comparable.With_zero (struct include T let zero = zero include V end) include Pretty_printer.Register(struct include T let module_name = "Core_kernel.Std.Float" let to_string = to_string end) module O = struct let ( + ) = ( + ) let ( - ) = ( - ) let ( * ) = ( * ) let ( / ) = ( / ) let ( ~- ) = ( ~- ) include (Replace_polymorphic_compare : Polymorphic_compare_intf.Infix with type t := t) include Robustly_comparable let abs = abs let neg = neg let zero = zero let of_int = of_int let of_float x = x end TEST_MODULE = struct let check v expect = match Validate.result v, expect with | Ok (), `Ok | Error _, `Error -> () | r, expect -> failwiths "mismatch" (r, expect) <:sexp_of< unit Or_error.t * [ `Ok | `Error ] >> ;; TEST_UNIT = check (validate_lbound ~min:(Incl 0.) nan) `Error TEST_UNIT = check (validate_lbound ~min:(Incl 0.) infinity) `Error TEST_UNIT = check (validate_lbound ~min:(Incl 0.) neg_infinity) `Error TEST_UNIT = check (validate_lbound ~min:(Incl 0.) (-1.)) `Error TEST_UNIT = check (validate_lbound ~min:(Incl 0.) 0.) `Ok TEST_UNIT = check (validate_lbound ~min:(Incl 0.) 1.) `Ok TEST_UNIT = check (validate_ubound ~max:(Incl 0.) nan) `Error TEST_UNIT = check (validate_ubound ~max:(Incl 0.) infinity) `Error TEST_UNIT = check (validate_ubound ~max:(Incl 0.) neg_infinity) `Error TEST_UNIT = check (validate_ubound ~max:(Incl 0.) (-1.)) `Ok TEST_UNIT = check (validate_ubound ~max:(Incl 0.) 0.) `Ok TEST_UNIT = check (validate_ubound ~max:(Incl 0.) 1.) `Error (* Some of the following tests used to live in lib_test/core_float_test.ml. *) let () = Random.init 137 let (=) = Pervasives.(=) let (>=) = Pervasives.(>=) let (+) = Pervasives.(+) let (-) = Pervasives.(-) let ( * ) = Pervasives.( * ) (* round: ... <-)[-><-)[-><-)[-><-)[-><-)[-><-)[-> ... ... -+-----+-----+-----+-----+-----+-----+- ... ... -3 -2 -1 0 1 2 3 ... so round x -. x should be in (-0.5,0.5] *) let round_test x = let y = round x in -0.5 < y -. x && y -. x <= 0.5 let iround_up_vs_down_test x = let expected_difference = if Parts.fractional (modf x) = 0. then 0 else 1 in ((iround_up_exn x) - (iround_down_exn x)) = expected_difference let test_all_four x ~specialized_iround ~specialized_iround_exn ~dir ~validate = let result1 = iround x ~dir in let result2 = try Some (iround_exn x ~dir) with _exn -> None in let result3 = specialized_iround x in let result4 = try Some (specialized_iround_exn x) with _exn -> None in let (=) = Pervasives.(=) in if result1 = result2 && result2 = result3 && result3 = result4 then validate result1 else false (* iround ~dir:`Nearest built so this should always be true *) let iround_nearest_test x = test_all_four x ~specialized_iround:iround_nearest ~specialized_iround_exn:iround_nearest_exn ~dir:`Nearest ~validate:(function | None -> true | Some y -> let y = of_int y in -0.5 < y -. x && y -. x <= 0.5) (* iround_down: ... )[<---)[<---)[<---)[<---)[<---)[<---)[ ... ... -+-----+-----+-----+-----+-----+-----+- ... ... -3 -2 -1 0 1 2 3 ... so x -. iround_down x should be in [0,1) *) let iround_down_test x = test_all_four x ~specialized_iround:iround_down ~specialized_iround_exn:iround_down_exn ~dir:`Down ~validate:(function | None -> true | Some y -> let y = of_int y in 0. <= x -. y && x -. y < 1.) (* iround_up: ... ](--->](--->](--->](--->](--->](--->]( ... ... -+-----+-----+-----+-----+-----+-----+- ... ... -3 -2 -1 0 1 2 3 ... so iround_up x -. x should be in [0,1) *) let iround_up_test x = test_all_four x ~specialized_iround:iround_up ~specialized_iround_exn:iround_up_exn ~dir:`Up ~validate:(function | None -> true | Some y -> let y = of_int y in 0. <= y -. x && y -. x < 1.) (* iround_towards_zero: ... ](--->](--->](---><--->)[<---)[<---)[ ... ... -+-----+-----+-----+-----+-----+-----+- ... ... -3 -2 -1 0 1 2 3 ... so abs x -. abs (iround_towards_zero x) should be in [0,1) *) let iround_towards_zero_test x = test_all_four x ~specialized_iround:iround_towards_zero ~specialized_iround_exn:iround_towards_zero_exn ~dir:`Zero ~validate:(function | None -> true | Some y -> let x = abs x in let y = abs (of_int y) in 0. <= x -. y && x -. y < 1. && (sign x = sign y || y = 0.0)) (* Easy cases that used to live inline with the code above. *) TEST = iround_up (-3.4) = Some (-3) TEST = iround_up 0.0 = Some 0 TEST = iround_up 3.4 = Some 4 TEST = iround_up_exn (-3.4) = -3 TEST = iround_up_exn 0.0 = 0 TEST = iround_up_exn 3.4 = 4 TEST = iround_down (-3.4) = Some (-4) TEST = iround_down 0.0 = Some 0 TEST = iround_down 3.4 = Some 3 TEST = iround_down_exn (-3.4) = -4 TEST = iround_down_exn 0.0 = 0 TEST = iround_down_exn 3.4 = 3 TEST = iround_towards_zero (-3.4) = Some (-3) TEST = iround_towards_zero 0.0 = Some 0 TEST = iround_towards_zero 3.4 = Some 3 TEST = iround_towards_zero_exn (-3.4) = -3 TEST = iround_towards_zero_exn 0.0 = 0 TEST = iround_towards_zero_exn 3.4 = 3 TEST = iround_nearest (-3.6) = Some (-4) TEST = iround_nearest (-3.5) = Some (-3) TEST = iround_nearest (-3.4) = Some (-3) TEST = iround_nearest 0.0 = Some 0 TEST = iround_nearest 3.4 = Some 3 TEST = iround_nearest 3.5 = Some 4 TEST = iround_nearest 3.6 = Some 4 TEST = iround_nearest_exn (-3.6) = -4 TEST = iround_nearest_exn (-3.5) = -3 TEST = iround_nearest_exn (-3.4) = -3 TEST = iround_nearest_exn 0.0 = 0 TEST = iround_nearest_exn 3.4 = 3 TEST = iround_nearest_exn 3.5 = 4 TEST = iround_nearest_exn 3.6 = 4 let special_values_test () = round (-.1.50001) = -.2. && round (-.1.5) = -.1. && round (-.0.50001) = -.1. && round (-.0.5) = 0. && round 0.49999 = 0. && round 0.5 = 1. && round 1.49999 = 1. && round 1.5 = 2. && iround_exn ~dir:`Up (-.2.) = -2 && iround_exn ~dir:`Up (-.1.9999) = -1 && iround_exn ~dir:`Up (-.1.) = -1 && iround_exn ~dir:`Up (-.0.9999) = 0 && iround_exn ~dir:`Up 0. = 0 && iround_exn ~dir:`Up 0.00001 = 1 && iround_exn ~dir:`Up 1. = 1 && iround_exn ~dir:`Up 1.00001 = 2 && iround_up_exn (-.2.) = -2 && iround_up_exn (-.1.9999) = -1 && iround_up_exn (-.1.) = -1 && iround_up_exn (-.0.9999) = 0 && iround_up_exn 0. = 0 && iround_up_exn 0.00001 = 1 && iround_up_exn 1. = 1 && iround_up_exn 1.00001 = 2 && iround_exn ~dir:`Down (-.1.00001) = -2 && iround_exn ~dir:`Down (-.1.) = -1 && iround_exn ~dir:`Down (-.0.00001) = -1 && iround_exn ~dir:`Down 0. = 0 && iround_exn ~dir:`Down 0.99999 = 0 && iround_exn ~dir:`Down 1. = 1 && iround_exn ~dir:`Down 1.99999 = 1 && iround_exn ~dir:`Down 2. = 2 && iround_down_exn (-.1.00001) = -2 && iround_down_exn (-.1.) = -1 && iround_down_exn (-.0.00001) = -1 && iround_down_exn 0. = 0 && iround_down_exn 0.99999 = 0 && iround_down_exn 1. = 1 && iround_down_exn 1.99999 = 1 && iround_down_exn 2. = 2 && iround_exn ~dir:`Zero (-.2.) = -2 && iround_exn ~dir:`Zero (-.1.99999) = -1 && iround_exn ~dir:`Zero (-.1.) = -1 && iround_exn ~dir:`Zero (-.0.99999) = 0 && iround_exn ~dir:`Zero 0.99999 = 0 && iround_exn ~dir:`Zero 1. = 1 && iround_exn ~dir:`Zero 1.99999 = 1 && iround_exn ~dir:`Zero 2. = 2 let is_64_bit_platform = of_int max_int >= 2. ** 60. (* Tests for values close to [iround_lbound] and [iround_ubound]. *) let extremities_test ~round = if is_64_bit_platform then (* 64 bits *) round (2.0 ** 62. -. 512.) = Some (max_int - 511) && round (2.0 ** 62. -. 1024.) = Some (max_int - 1023) && round (-. (2.0 ** 62.)) = Some min_int && round (-. (2.0 ** 62. -. 512.)) = Some (min_int + 512) && round (2.0 ** 62.) = None && round (-. (2.0 ** 62. +. 1024.)) = None else let int_size_minus_one = float_of_int (Core_int.num_bits - 1) in (* 32 bits *) round (2.0 ** int_size_minus_one -. 1.) = Some max_int && round (2.0 ** int_size_minus_one -. 2.) = Some (max_int - 1) && round (-. (2.0 ** int_size_minus_one)) = Some min_int && round (-. (2.0 ** int_size_minus_one -. 1.)) = Some (min_int + 1) && round (2.0 ** int_size_minus_one) = None && round (-. (2.0 ** int_size_minus_one +. 1.)) = None TEST = extremities_test ~round:iround_down TEST = extremities_test ~round:iround_up TEST = extremities_test ~round:iround_nearest TEST = extremities_test ~round:iround_towards_zero (* test values beyond the integers range *) let large_value_test x = true && iround_down x = None && iround ~dir:`Down x = None && iround_up x = None && iround ~dir:`Up x = None && iround_towards_zero x = None && iround ~dir:`Zero x = None && iround_nearest x = None && iround ~dir:`Nearest x = None && (try ignore (iround_down_exn x); false with _ -> true) && (try ignore (iround_exn ~dir:`Down x); false with _ -> true) && (try ignore (iround_up_exn x); false with _ -> true) && (try ignore (iround_exn ~dir:`Up x); false with _ -> true) && (try ignore (iround_towards_zero_exn x); false with _ -> true) && (try ignore (iround_exn ~dir:`Zero x); false with _ -> true) && (try ignore (iround_nearest_exn x); false with _ -> true) && (try ignore (iround_exn ~dir:`Nearest x); false with _ -> true) && round_down x = x && round ~dir:`Down x = x && round_up x = x && round ~dir:`Up x = x && round_towards_zero x = x && round ~dir:`Zero x = x && round_nearest x = x && round ~dir:`Nearest x = x let large_numbers = Core_list.concat ( Core_list.init (1024 - 64) ~f:(fun x -> let x = float (x + 64) in let y = [2. ** x; 2. ** x -. 2. ** (x -. 53.); (* one ulp down *) 2. ** x +. 2. ** (x -. 52.)] (* one ulp up *) in y @ (List.map y ~f:neg))) @ [infinity; neg_infinity] TEST = Core_list.for_all large_numbers ~f:large_value_test let numbers_near_powers_of_two = Core_list.concat ( Core_list.init (if is_64_bit_platform then 62 else 30) ~f:(fun i -> let pow2 = 2. ** float i in let x = [ pow2; one_ulp `Down (pow2 +. 0.5); pow2 +. 0.5; one_ulp `Down (pow2 +. 1.0); pow2 +. 1.0; one_ulp `Down (pow2 +. 1.5); pow2 +. 1.5; one_ulp `Down (pow2 +. 2.0); pow2 +. 2.0; one_ulp `Down (pow2 *. 2.0 -. 1.0); ] in x @ (List.map x ~f:neg) )) TEST = Core_list.for_all numbers_near_powers_of_two ~f:iround_up_vs_down_test TEST = Core_list.for_all numbers_near_powers_of_two ~f:iround_nearest_test TEST = Core_list.for_all numbers_near_powers_of_two ~f:iround_down_test TEST = Core_list.for_all numbers_near_powers_of_two ~f:iround_up_test TEST = Core_list.for_all numbers_near_powers_of_two ~f:iround_towards_zero_test TEST = Core_list.for_all numbers_near_powers_of_two ~f:round_test (* code for generating random floats on which to test functions *) let rec absirand () = let rec aux acc cnt = if cnt = 0 then acc else let bit = if Random.bool () then 1 else 0 in aux (2 * acc + bit) (cnt - 1) in let result = aux 0 (if is_64_bit_platform then 62 else 30) in if result >= max_int - 255 then (* On a 64-bit box, [float x > max_int] when [x >= max_int - 255], so [iround (float x)] would be out of bounds. So we try again. This branch of code runs with probability 6e-17 :-) As such, we have some fixed tests in [extremities_test] above, to ensure that we do always check some examples in that range. *) absirand () else result (* -max_int <= frand () <= max_int *) let frand () = let x = (float (absirand ())) +. Random.float 1.0 in if Random.bool () then -1.0 *. x else x let randoms = Core_list.init ~f:(fun _ -> frand ()) 10_000 TEST = Core_list.for_all randoms ~f:iround_up_vs_down_test TEST = Core_list.for_all randoms ~f:iround_nearest_test TEST = Core_list.for_all randoms ~f:iround_down_test TEST = Core_list.for_all randoms ~f:iround_up_test TEST = Core_list.for_all randoms ~f:iround_towards_zero_test TEST = Core_list.for_all randoms ~f:round_test TEST = special_values_test () TEST = iround_nearest_test (of_int max_int) TEST = iround_nearest_test (of_int min_int) end BENCH_MODULE "Simple" = struct (* The [of_string] is so that won't get inlined. The values of [x] and [y] have no special significance. *) let x = of_string "1.0000000001000000111" let y = of_string "2.0000000001000000111" BENCH "add" = x +. y BENCH "mul" = x *. y BENCH "div" = x /. y BENCH "exp" = x ** y BENCH "log" = log x BENCH "sqrt" = sqrt x end BENCH_MODULE "Rounding" = struct let x = of_string "1.0000000001000000111" BENCH "iround_down_exn" = iround_down_exn x BENCH "iround_nearest_exn" = iround_nearest_exn x BENCH "iround_up_exn" = iround_up_exn x BENCH "iround_towards_zero_exn" = iround_towards_zero_exn x BENCH "Pervasives.int_of_float" = Pervasives.int_of_float x BENCH_MODULE "imm" = struct (* Here we check that rounding functions don't force boxing. We observe this by noting the lack of allocation when calling with a float that compiler can avoid boxing. Without the tuning above that allows, e.g., [iround_nearest_exn] to avoid forcing callers to box floats, these allocate: Estimated testing time 5s (5 benchmarks x 1s). Change using -quota SECS. ┌─────────────────────────────────────────────────┬──────────┬────────────┠│ Name │ Time/Run │ Percentage │ ├─────────────────────────────────────────────────┼──────────┼────────────┤ │ [float.ml:Rounding.imm] iround_down_exn │ 3.69ns │ 45.10% │ │ [float.ml:Rounding.imm] iround_nearest_exn │ 3.96ns │ 48.42% │ │ [float.ml:Rounding.imm] iround_up_exn │ 8.19ns │ 100.00% │ │ [float.ml:Rounding.imm] iround_towards_zero_exn │ 3.73ns │ 45.52% │ │ [float.ml:Rounding.imm] Pervasives.int_of_float │ 3.36ns │ 41.10% │ └─────────────────────────────────────────────────┴──────────┴────────────┘ *) let x = [| x |] BENCH "iround_down_exn" = iround_down_exn x.(0) BENCH "iround_nearest_exn" = iround_nearest_exn x.(0) BENCH "iround_up_exn" = iround_up_exn x.(0) BENCH "iround_towards_zero_exn" = iround_towards_zero_exn x.(0) BENCH "Pervasives.int_of_float" = Pervasives.int_of_float x.(0) end end (* These tests show the degenerate cases for the OCaml [**] operator. The slowness of this primitive can be traced back to the implementation of [pow] in [glibc]. Also see our Perf notes for more about this issue. *) BENCH_MODULE "pow (**)" = struct BENCH "very slow" = 1.0000000000000020 ** 0.5000000000000000 BENCH "slow" = 1.0000000000000020 ** 0.5000000000100000 BENCH "slow" = 1.0000000000000020 ** 0.4999999999000000 BENCH "fast" = 1.0000000000000020 ** 0.4999900000000000 end core_kernel-113.00.00/src/float.mli000066400000000000000000000000511256461164500167110ustar00rootroot00000000000000include Float_intf.S with type t = float core_kernel-113.00.00/src/float_intf.ml000066400000000000000000000276571256461164500176050ustar00rootroot00000000000000(** Floating-point representation and utilities. *) module Binable = Binable0 module type S = sig type t with typerep type outer = t with bin_io, sexp, typerep include Floatable.S with type t := t (** [max] and [min] will return nan if either argument is nan. The [validate_*] functions always fail if class is [Nan] or [Infinite]. *) include Identifiable.S with type t := t include Comparable.With_zero with type t := t (** The results of robust comparisons on [nan] should be considered undefined. *) include Robustly_comparable.S with type t := t (** [validate_ordinary] fails if class is [Nan] or [Infinite]. *) val validate_ordinary : t Validate.check val nan : t val infinity : t val neg_infinity : t val max_value : t (** equal to [infinity] *) val min_value : t (** equal to [neg_infinity] *) val zero : t val one : t val minus_one : t (** See {!module:Robust_compare} *) val robust_comparison_tolerance : t (** The difference between 1.0 and the smallest exactly representable floating-point number greater than 1.0. That is: [epsilon_float = (one_ulp `Up 1.0) -. 1.0] This gives the relative accuracy of type [t], in the sense that for numbers on the order of [x], the roundoff error is on the order of [x *. float_epsilon]. See also: http://en.wikipedia.org/wiki/Machine_epsilon *) val epsilon_float : t val max_finite_value : t (** [min_positive_subnormal_value = 2 ** -1074] [min_positive_normal_value = 2 ** -1022] *) val min_positive_subnormal_value : t val min_positive_normal_value : t (** An order-preserving bijection between all floats except for nans, and all int64s with absolute value smaller than or equal to [2**63 - 2**52]. Note both 0. and -0. map to 0L. *) val to_int64_preserve_order : t -> int64 option val to_int64_preserve_order_exn : t -> int64 (** returns [nan] if the absolute value of the argument is too large *) val of_int64_preserve_order : int64 -> t (** The next or previous representable float. ULP stands for "unit of least precision", and is the spacing between floating point numbers. Both [one_ulp `Up infinity] and [one_ulp `Down neg_infinity] return a nan. *) val one_ulp : [`Up | `Down] -> t -> t val of_int : int -> t val to_int : t -> int val of_int64 : int64 -> t val to_int64 : t -> int64 (** [round] rounds a float to an integer float. [iround{,_exn}] rounds a float to an int. Both round according to a direction [dir], with default [dir] being [`Nearest]. {v | `Down | rounds toward Float.neg_infinity | | `Up | rounds toward Float.infinity | | `Nearest | rounds to the nearest int ("round half-integers up") | | `Zero | rounds toward zero | v} [iround_exn] raises when trying to handle nan or trying to handle a float outside the range [float min_int, float max_int). Here are some examples for [round] for each direction: {v | `Down | [-2.,-1.) to -2. | [-1.,0.) to -1. | [0.,1.) to 0., [1.,2.) to 1. | | `Up | (-2.,-1.] to -1. | (-1.,0.] to -0. | (0.,1.] to 1., (1.,2.] to 2. | | `Zero | (-2.,-1.] to -1. | (-1.,1.) to 0. | [1.,2.) to 1. | | `Nearest | [-1.5,-0.5) to -1. | [-0.5,0.5) to 0. | [0.5,1.5) to 1. | v} For convenience, versions of these functions with the [dir] argument hard-coded are provided. If you are writing performance-critical code you should use the versions with the hard-coded arguments (e.g. [iround_down_exn]). The [_exn] ones are the fastest. The following properties hold: - [of_int (iround_*_exn i) = i] for any float [i] that is an integer with [min_int <= i <= max_int]. - [round_* i = i] for any float [i] that is an integer. - [iround_*_exn (of_int i) = i] for any int [i] with [-2**52 <= i <= 2**52]. *) val round : ?dir:[`Zero|`Nearest|`Up|`Down] -> t -> t val iround : ?dir:[`Zero|`Nearest|`Up|`Down] -> t -> int option val iround_exn : ?dir:[`Zero|`Nearest|`Up|`Down] -> t -> int val round_towards_zero : t -> t val round_down : t -> t val round_up : t -> t val round_nearest : t -> t val iround_towards_zero : t -> int option val iround_down : t -> int option val iround_up : t -> int option val iround_nearest : t -> int option val iround_towards_zero_exn : t -> int val iround_down_exn : t -> int val iround_up_exn : t -> int val iround_nearest_exn : t -> int val int63_round_nearest_exn : t -> Core_int63.t (** If [f <= iround_lbound || f >= iround_ubound], then [iround*] functions will refuse to round [f], returning [None] or raising as appropriate. *) val iround_lbound : t val iround_ubound : t val is_nan : t -> bool (** includes positive and negative Float.infinity *) val is_inf : t -> bool (** min and max that return the other value if one of the values is a [nan]. Returns [nan] if both arguments are [nan]. *) val min_inan : t -> t -> t val max_inan : t -> t -> t val (+) : t -> t -> t val (-) : t -> t -> t val ( * ) : t -> t -> t val (/) : t -> t -> t val (~-) : t -> t (** Returns the fractional part and the whole (i.e. integer) part. For example, [modf (-3.14)] returns [{ fractional = -0.14; integral = -3.; }]! *) module Parts : sig type t val fractional : t -> outer val integral : t -> outer end val modf : t -> Parts.t (** [mod_float x y] returns a result with the same sign as [x]. It returns [nan] if [y] is [0]. It is basically {[ let mod_float x y = x -. float(truncate(x/.y)) *. y]} not {[ let mod_float x y = x -. floor(x/.y) *. y ]} and therefore resembles [mod] on integers more than [%]. *) val mod_float : t -> t -> t (** {6 Ordinary functions for arithmetic operations} These are for modules that inherit from t, since the infix operators are more convenient *) val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val scale : t -> t -> t val abs : t -> t (** A sub-module designed to be opened to make working with floats more convenient. *) module O : sig val ( + ) : t -> t -> t val ( - ) : t -> t -> t val ( * ) : t -> t -> t val ( / ) : t -> t -> t val ( ~- ) : t -> t include Polymorphic_compare_intf.Infix with type t := t include Robustly_comparable.S with type t := t val abs : t -> t val neg : t -> t val zero : t val of_int : int -> t val of_float : float -> t end (** Like [to_string], but guaranteed to be round-trippable. It usually yields as few significant digits as possible. That is, it won't print [3.14] as [3.1400000000000001243]. The only exception is that occasionally it will output 17 significant digits when the number can be represented with just 16 (but not 15 or less) of them. *) val to_string_round_trippable : float -> string (** Pretty print float, for example [to_string_hum ~decimals:3 1234.1999 = "1_234.200"] [to_string_hum ~decimals:3 ~strip_zero:true 1234.1999 = "1_234.2" ]. No delimiters are inserted to the right of the decimal. *) val to_string_hum : ?delimiter:char (** defaults to ['_'] *) -> ?decimals:int (** defaults to [3] *) -> ?strip_zero:bool (** defaults to [false] *) -> float -> string (** Produce a lossy compact string representation of the float. The float is scaled by an appropriate power of 1000 and rendered with one digit after the decimal point, except that the decimal point is written as '.', 'k', 'm', 'g', 't', or 'p' to indicate the scale factor. (However, if the digit after the "decimal" point is 0, it is suppressed.) The smallest scale factor that allows the number to be rendered with at most 3 digits to the left of the decimal is used. If the number is too large for this format (i.e., the absolute value is at least 999.95e15), scientific notation is used instead. E.g.: {[ to_padded_compact_string (-0.01) = "-0 " to_padded_compact_string 1.89 = "1.9" to_padded_compact_string 999_949.99 = "999k9" to_padded_compact_string 999_950. = "1m " ]} In the case where the digit after the "decimal", or the "decimal" itself are omitted, the numbers are padded on the right with spaces to ensure the last two columns of the string always correspond to the decimal and the digit afterward (except in the case of scientific notation, where the exponent is the right-most element in the string and could take up to four characters). {[ to_padded_compact_string 1. = "1 "; to_padded_compact_string 1.e6 = "1m "; to_padded_compact_string 1.e16 = "1.e+16"; to_padded_compact_string max_finite_value = "1.8e+308"; ]} Numbers in the range -.05 < x < .05 are rendered as "0 " or "-0 ". Other cases: {[ to_padded_compact_string nan = "nan " to_padded_compact_string infinity = "inf " to_padded_compact_string neg_infinity = "-inf " ]} Exact ties are resolved to even in the decimal: {| to_padded_compact_string 3.25 = "3.2" to_padded_compact_string 3.75 = "3.8" to_padded_compact_string 33_250. = "33k2" to_padded_compact_string 33_350. = "33k4" |} *) val to_padded_compact_string : float -> string (** [ldexp x n] returns [x *. 2 ** n] *) val ldexp : t -> int -> t (** [frexp f] returns the pair of the significant and the exponent of f. When f is zero, the significant x and the exponent n of f are equal to zero. When f is non-zero, they are defined by [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *) val frexp : t -> t * int module Class : sig type t = | Infinite | Nan | Normal | Subnormal | Zero with bin_io, sexp include Stringable.S with type t := t end (** return the Class.t. Excluding nan the floating-point "number line" looks like: {v t Class.t example ^ neg_infinity Infinite neg_infinity | neg normals Normal -3.14 | neg subnormals Subnormal -.2. ** -1023. | (-/+) zero Zero 0. | pos subnormals Subnormal 2. ** -1023. | pos normals Normal 3.14 v infinity Infinite infinity v} *) val classify : t -> Class.t (** [is_finite t] returns [true] iff [classify t] is in [Normal; Subnormal; Zero;]. *) val is_finite : t -> bool module Sign : sig type t = Neg | Zero | Pos with sexp end val sign : t -> Sign.t (** These functions construct and destruct 64-bit floating point numbers based on their IEEE representation with sign bit, 11-bit non-negative (biased) exponent, and 52-bit non-negative mantissa (or significand). See wikipedia for details of the encoding: http://en.wikipedia.org/wiki/Double-precision_floating-point_format. In particular, if 1 <= exponent <= 2046, then: create_ieee_exn ~negative:false ~exponent ~mantissa = 2 ** (exponent - 1023) * (1 + (2 ** -52) * mantissa) *) val create_ieee : negative:bool -> exponent:int -> mantissa:Core_int63.t -> t Or_error.t val create_ieee_exn : negative:bool -> exponent:int -> mantissa:Core_int63.t -> t val ieee_negative : t -> bool val ieee_exponent : t -> int val ieee_mantissa : t -> Core_int63.t (** S-expressions contain at most 8 significant digits. *) module Terse : sig type t = outer with bin_io, sexp include Stringable.S with type t := t end end core_kernel-113.00.00/src/float_robust_compare.ml000066400000000000000000000014731256461164500216550ustar00rootroot00000000000000(* This is factored out of float.ml in order to break a module dependency cycle. *) module type S = sig (* intended to be a tolerance on human-entered floats *) val robust_comparison_tolerance : float include Robustly_comparable.S with type t := float end module Make(T : sig val robust_comparison_tolerance : float end) : S = struct let robust_comparison_tolerance = T.robust_comparison_tolerance let ( >=. ) x y = x >= y -. robust_comparison_tolerance let ( <=. ) x y = y >=. x let ( =. ) x y = x >=. y && y >=. x let ( >. ) x y = x > y +. robust_comparison_tolerance let ( <. ) x y = y >. x let ( <>. ) x y = not (x =. y) let robustly_compare x y = let d = x -. y in if d < ~-. robust_comparison_tolerance then -1 else if d > robust_comparison_tolerance then 1 else 0 end core_kernel-113.00.00/src/float_robust_compare.mli000066400000000000000000000005171256461164500220240ustar00rootroot00000000000000(* This is factored out of float.ml in order to break a module dependency cycle. *) module type S = sig (** intended to be a tolerance on human-entered floats *) val robust_comparison_tolerance : float include Robustly_comparable.S with type t := float end module Make(T : sig val robust_comparison_tolerance : float end) : S core_kernel-113.00.00/src/floatable.ml000066400000000000000000000001401256461164500173630ustar00rootroot00000000000000module type S = sig type t val of_float : float -> t val to_float : t -> float end core_kernel-113.00.00/src/fn.ml000066400000000000000000000015671256461164500160530ustar00rootroot00000000000000let const c _ = c external ignore : _ -> unit = "%ignore" (* this has the same behavior as [Pervasives.ignore] *) let non f x = not (f x) let forever f = let rec forever () = f (); forever () in try forever () with e -> e external id : 'a -> 'a = "%identity" external ( |! ) : 'a -> ( 'a -> 'b) -> 'b = "%revapply" external ( |> ) : 'a -> ( 'a -> 'b) -> 'b = "%revapply" TEST = 1 |> fun x -> x = 1 TEST = 1 |> fun x -> x + 1 |> fun y -> y = 2 (* The typical use case for these functions is to pass in functional arguments and get functions as a result. *) let compose f g x = f (g x) let flip f x y = f y x let rec apply_n_times ~n f x = if n <= 0 then x else apply_n_times ~n:(n - 1) f (f x) TEST = 0 = apply_n_times ~n:0 (fun _ -> assert false) 0 TEST = 0 = apply_n_times ~n:(-3) (fun _ -> assert false) 0 TEST = 10 = apply_n_times ~n:10 ((+) 1) 0 core_kernel-113.00.00/src/fn.mli000066400000000000000000000022561256461164500162200ustar00rootroot00000000000000(** various combinators for functions *) (** A 'pipe' operator. Deprecated. *) external ( |! ) : 'a -> ( 'a -> 'b) -> 'b = "%revapply" (** A pipe operator, equivalent to |!, but this notation is more broadly accepted *) external ( |> ) : 'a -> ( 'a -> 'b) -> 'b = "%revapply" (** produces a function that just returns its first argument *) val const : 'a -> _ -> 'a (** * [ignore] is the same as [Pervasives.ignore]. It is useful to have here so * that code that rebinds [ignore] can still refer to [Fn.ignore]. *) external ignore : _ -> unit = "%ignore" (** Negates a function *) val non : ('a -> bool) -> 'a -> bool (** [forever f] runs [f ()] until it throws an exception and returns the exception. This function is useful for read_line loops, etc. *) val forever : (unit -> unit) -> exn (** [apply_n_times ~n f x] is the [n]-fold application of [f] to [x]. *) val apply_n_times : n:int -> ('a -> 'a) -> ('a -> 'a) (** The identity function*) external id : 'a -> 'a = "%identity" (** [compose f g x] is [f (g x)] *) val compose : ('b -> 'c) -> ('a -> 'b) -> ('a -> 'c) (** reverse the order of arguments for a binary function *) val flip : ('a -> 'b -> 'c) -> ('b -> 'a -> 'c) core_kernel-113.00.00/src/force_once.ml000066400000000000000000000006031256461164500175400ustar00rootroot00000000000000open Sexplib type 'a z = | Forced | Not_forced of (unit -> 'a) type 'a t = 'a z ref let create f = ref (Not_forced f) let ignore () = create (fun () -> ()) let force t = match !t with | Forced -> failwith "Force_once.force" | Not_forced f -> t := Forced; f() let sexp_of_t _ t = match !t with | Forced -> Sexp.Atom "" | Not_forced _ -> Sexp.Atom "" core_kernel-113.00.00/src/force_once.mli000066400000000000000000000007121256461164500177120ustar00rootroot00000000000000open Sexplib (** A "force_once" is a thunk that can only be forced once. Subsequent forces will raise an exception. *) type 'a t (** [create f] creates a new force_once *) val create : (unit -> 'a) -> 'a t (** [force t] runs the thunk if it hadn't already been forced, else it raises an exception. *) val force : 'a t -> 'a (** [ignore ()] = create (fun () -> ()) *) val ignore : unit -> unit t val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t core_kernel-113.00.00/src/fqueue.ml000066400000000000000000000004571256461164500167370ustar00rootroot00000000000000 include Fdeque let enqueue = enqueue_back let enqueue_top = enqueue_front let bot_exn = peek_back_exn let bot = peek_back let top_exn = peek_front_exn let top = peek_front let dequeue_exn = dequeue_front_exn let dequeue = dequeue_front let discard_exn = drop_front_exn core_kernel-113.00.00/src/fqueue.mli000066400000000000000000000044321256461164500171050ustar00rootroot00000000000000(** A simple polymorphic functional queue. Use this data structure for strictly first-in, first-out access to a sequence of values. For a similar data structure with enqueue and dequeue accessors on both ends of a sequence, see [Fdeque]. Amortized running times assumes that enqueue/dequeue are used sequentially, threading the changing Fqueue through the calls. *) type 'a t with bin_io, compare, sexp include Container.S1 with type 'a t := 'a t include Invariant.S1 with type 'a t := 'a t (** The empty queue *) val empty : 'a t (** [enqueue t x] returns a queue with adds [x] to the end of [t]. Complexity: O(1) *) val enqueue : 'a t -> 'a -> 'a t (** enqueue a single element on the *top* of the queue. Complexity: amortized O(1) [enqueue_top] is deprecated, use [Fdeque.t] instead. *) val enqueue_top : 'a t -> 'a -> 'a t (** returns the bottom (most-recently enqueued element). Raises [Empty] if no element is found. Complexity: O(1) [bot_exn] is deprecated, use [Fdeque.t] instead. *) val bot_exn : 'a t -> 'a (** like [bot_exn], but returns result optionally, without exception. Complexity: O(1) [bot] is deprecated, use [Fdeque.t] instead. *) val bot : 'a t -> 'a option (** Like [bot_exn], except returns top (least-recently enqueued element. Complexity: O(1) *) val top_exn : 'a t -> 'a (** like [top_exn], but returns result optionally, without exception, Complexity: O(1) *) val top : 'a t -> 'a option (** [dequeue_exn t] removes and returns the front of [t], raising [Empty] if [t] is empty. Complexity: amortized O(1)*) val dequeue_exn : 'a t -> 'a * 'a t (** Like [dequeue_exn], but returns result optionally, without exception. Complexity: amortized O(1) *) val dequeue : 'a t -> ('a * 'a t) option (** Returns version of queue with top element removed. Complexity: amortized O(1) *) val discard_exn : 'a t -> 'a t (** [to_list t] returns a list of the elements in [t] in order from least-recently-added (at the head) to most-recently added (at the tail). Complexity: O(n) *) val to_list : 'a t -> 'a list (** complexity: O(1) *) val length : 'a t -> int (** complexity: O(1) *) val is_empty : 'a t -> bool val singleton : 'a -> 'a t module Stable : sig module V1 : sig type nonrec 'a t = 'a t with bin_io, compare, sexp end end core_kernel-113.00.00/src/hash_heap.ml000066400000000000000000000121561256461164500173640ustar00rootroot00000000000000(** A hash-heap is a combination of a heap and a hashtbl that supports constant time lookup, and log(n) time removal and replacement of elements in addition to the normal heap operations. *) module Hashtbl = Core_hashtbl module Heap = Heap.Removable module type Key = Hashtbl.Key module type S = sig module Key : Key type 'a t val create : ?min_size:int -> ('a -> 'a -> int) -> 'a t val copy : 'a t -> 'a t val push : 'a t -> key:Key.t -> data:'a -> [`Ok | `Key_already_present] val push_exn : 'a t -> key:Key.t -> data:'a -> unit val replace : 'a t -> key:Key.t -> data:'a -> unit val remove : 'a t -> Key.t -> unit val mem : 'a t -> Key.t -> bool val top : 'a t -> 'a option val top_exn : 'a t -> 'a val top_with_key : 'a t -> (Key.t * 'a) option val top_with_key_exn : 'a t -> (Key.t * 'a) val pop_with_key : 'a t -> (Key.t * 'a) option val pop_with_key_exn : 'a t -> (Key.t * 'a) val pop : 'a t -> 'a option val pop_exn : 'a t -> 'a val pop_if_with_key : 'a t -> (key:Key.t -> data:'a -> bool) -> (Key.t * 'a) option val pop_if : 'a t -> ('a -> bool) -> 'a option val find : 'a t -> Key.t -> 'a option val find_pop : 'a t -> Key.t -> 'a option val find_exn : 'a t -> Key.t -> 'a val find_pop_exn : 'a t -> Key.t -> 'a (** Mutation of the heap during iteration is not supported, but there is no check to prevent it. The behavior of a heap that is mutated during iteration is undefined. *) val iter : 'a t -> f:(key:Key.t -> data:'a -> unit) -> unit val iter_vals : 'a t -> f:('a -> unit) -> unit (** Returns the list of all (key, value) pairs for given [Hash_heap]. *) val to_alist : 'a t -> (Key.t * 'a) list val length : 'a t -> int end module Make (Key : Key) : S with module Key = Key = struct module Key = Key module Table = Hashtbl.Make (Key) type 'a t = { heap : (Key.t * 'a) Heap.t; cmp : ('a -> 'a -> int); tbl : (Key.t * 'a) Heap.Elt.t Table.t; } let create ?min_size cmp = let initial_tbl_size = match min_size with | None -> 50 | Some s -> s in { heap = Heap.create ?min_size ~cmp:(fun (_, v1) (_, v2) -> cmp v1 v2) (); cmp; tbl = Table.create ~size:initial_tbl_size (); } (* [push_new_key] adds an entry to the heap without checking for duplicates. Thus it should only be called when the key is known not to be present already. *) let push_new_key t ~key ~data = let el = Heap.add_removable t.heap (key, data) in Hashtbl.set t.tbl ~key ~data:el let push t ~key ~data = match Hashtbl.find t.tbl key with | Some _ -> `Key_already_present | None -> push_new_key t ~key ~data; `Ok exception Key_already_present of Key.t with sexp let push_exn t ~key ~data = match push t ~key ~data with | `Ok -> () | `Key_already_present -> raise (Key_already_present key) let replace t ~key ~data = match Hashtbl.find t.tbl key with | None -> push_exn t ~key ~data | Some el -> Heap.remove t.heap el; push_new_key t ~key ~data ;; let remove t key = match Hashtbl.find t.tbl key with | None -> () | Some el -> Hashtbl.remove t.tbl key; Heap.remove t.heap el ;; let mem t key = Hashtbl.mem t.tbl key let top_with_key t = match Heap.top t.heap with | None -> None | Some (k, v) -> Some (k, v) let top t = match top_with_key t with | None -> None | Some (_, v) -> Some v let top_exn t = snd (Heap.top_exn t.heap) let top_with_key_exn t = Heap.top_exn t.heap let pop_with_key_exn t = let (k, v) = Heap.pop_exn t.heap in Hashtbl.remove t.tbl k; (k, v) let pop_with_key t = try Some (pop_with_key_exn t) with _ -> None let pop t = match pop_with_key t with | None -> None | Some (_, v) -> Some v let pop_exn t = snd (pop_with_key_exn t) let pop_if_with_key t f = match Heap.pop_if t.heap (fun (k, v) -> f ~key:k ~data:v) with | None -> None | Some (k, v) -> Hashtbl.remove t.tbl k; Some (k, v) let pop_if t f = match pop_if_with_key t (fun ~key:_ ~data -> f data) with | None -> None | Some (_k, v) -> Some v let find t key = match Hashtbl.find t.tbl key with | None -> None | Some el -> Some (snd (Heap.Elt.value_exn el)) ;; exception Key_not_found of Key.t with sexp let find_exn t key = match find t key with | Some el -> el | None -> raise (Key_not_found key) let find_pop t key = match Hashtbl.find t.tbl key with | None -> None | Some el -> let (_k, v) = Heap.Elt.value_exn el in Hashtbl.remove t.tbl key; Heap.remove t.heap el; Some v let find_pop_exn t key = match find_pop t key with | Some el -> el | None -> raise (Key_not_found key) let iter t ~f = Heap.iter t.heap ~f:(fun (k, v) -> f ~key:k ~data:v) let iter_vals t ~f = Heap.iter t.heap ~f:(fun (_k, v) -> f v) let to_alist t = Heap.to_list t.heap let length t = assert (Hashtbl.length t.tbl = Heap.length t.heap); Hashtbl.length t.tbl let copy t = let t' = create t.cmp in iter t ~f:(fun ~key ~data -> push_exn t' ~key ~data); t' ;; end core_kernel-113.00.00/src/hash_queue.ml000066400000000000000000000223641256461164500175750ustar00rootroot00000000000000(* A hash-queue is a combination of a queue and a hashtable that * supports constant-time lookup and removal of queue elements in addition to * the usual queue operations (enqueue, dequeue). The queue elements are * key-value pairs. The hashtable has one entry for each element of the queue. * * Calls to functions that would modify a hash-queue (e.g. enqueue, dequeue, * remove, replace) detect if a client is in the middle of iterating over the * queue (e.g. iter, fold, for_all, exists) and if so, raise an exception. *) (* for tail-recursive versions of List functions Can't open Std_internal due to cyclic dependencies *) module List = Core_list module Array = Core_array module Hashtbl = Core_hashtbl (* The key is used for the hashtable of queue elements. *) module type Key = Hashtbl.Key module type S = sig module Key : Key (** a hash-queue, where the values are of type 'a *) type 'a t with sexp_of include Container.S1 with type 'a t := 'a t (** [invariant t] checks the invariants of the queue. *) val invariant : 'a t -> unit (** [create ()] returns an empty queue. The arguments [growth_allowed] and [size] are referring to the underlying hashtable. *) val create : ?growth_allowed:bool (** defaults to true *) -> ?size:int (** initial size -- default 16 *) -> unit -> 'a t (** clear the queue *) val clear : 'a t -> unit (* Finding elements. *) (** [mem q k] returns true iff there is some (k, v) in the queue. *) val mem : 'a t -> Key.t -> bool (** [lookup t k] returns the value of the key-value pair in the queue with key k, if there is one. *) val lookup : 'a t -> Key.t -> 'a option val lookup_exn : 'a t -> Key.t -> 'a (* Adding, removing, and replacing elements. *) (** [enqueue t k v] adds the key-value pair (k, v) to the end of the queue, returning `Ok if the pair was added, or `Key_already_present if there is already a (k, v') in the queue. *) val enqueue : 'a t -> Key.t -> 'a -> [ `Ok | `Key_already_present ] val enqueue_exn : 'a t -> Key.t -> 'a -> unit (** [first t] returns the front element of the queue, without removing it. *) val first : 'a t -> 'a option (** [first_with_key t] returns the front element of the queue and its key, without removing it. *) val first_with_key : 'a t -> (Key.t * 'a) option (** [keys t] returns the keys in the order of the queue. *) val keys : 'a t -> Key.t list (** [dequeue t] returns the front element of the queue. *) val dequeue : 'a t -> 'a option val dequeue_exn : 'a t -> 'a (** [dequeue_with_key t] returns the front element of the queue and its key *) val dequeue_with_key : 'a t -> (Key.t * 'a) option val dequeue_with_key_exn : 'a t -> (Key.t * 'a) (** [dequeue_all t ~f] dequeues every element of the queue and applies f to each one. *) val dequeue_all : 'a t -> f:('a -> unit) -> unit (** [remove q k] removes the key-value pair with key k from the queue. *) val remove : 'a t -> Key.t -> [ `Ok | `No_such_key ] val remove_exn : 'a t -> Key.t -> unit (** [replace q k v] changes the value of key k in the queue to v. *) val replace : 'a t -> Key.t -> 'a -> [ `Ok | `No_such_key ] val replace_exn : 'a t -> Key.t -> 'a -> unit (* Iterating over elements *) (** [iter t ~f] applies f to each key and element of the queue. *) val iteri : 'a t -> f:(key:Key.t -> data:'a -> unit) -> unit val foldi : 'a t -> init:'b -> f:('b -> key:Key.t -> data:'a -> 'b) -> 'b end module Make (Key : Key) : S with module Key = Key = struct module Key = Key module Table = Hashtbl.Make (Key) module Key_value = struct module T = struct type 'a t = { key : Key.t; mutable value : 'a; } end include T let key t = t.key let value t = t.value let sexp_of_t sexp_of_a {key; value} = <:sexp_of< Key.t * a >> (key, value) end open Key_value.T module Elt = Doubly_linked.Elt type 'a t = { mutable num_readers : int; queue : 'a Key_value.t Doubly_linked.t; table : 'a Key_value.t Elt.t Table.t; } let sexp_of_t sexp_of_a t = <:sexp_of< a Key_value.t Doubly_linked.t >> t.queue let invariant t = assert (Doubly_linked.length t.queue = Hashtbl.length t.table); (* Look at each element in the queue, checking: * - every element in the queue is in the hash table * - there are no duplicate keys *) let keys = Table.create ~size:(Hashtbl.length t.table) () in Doubly_linked.iter t.queue ~f:(fun kv -> let key = kv.key in match Hashtbl.find t.table key with | None -> assert false | Some _ -> assert (not (Hashtbl.mem keys key)); Hashtbl.set keys ~key ~data:()); ;; let create ?(growth_allowed=true) ?(size=16) () = { num_readers = 0; queue = Doubly_linked.create (); table = Table.create ~growth_allowed ~size (); } ;; let read t f = t.num_readers <- t.num_readers + 1; Exn.protect ~f ~finally:(fun () -> t.num_readers <- t.num_readers - 1) ;; let ensure_can_modify t = if t.num_readers > 0 then failwith "It is an error to modify a Hash_queue.t while iterating over it."; ;; let clear t = ensure_can_modify t; Doubly_linked.clear t.queue; Hashtbl.clear t.table; ;; let length t = Hashtbl.length t.table let is_empty t = length t = 0 let lookup t k = match Hashtbl.find t.table k with | None -> None | Some elt -> Some (Elt.value elt).value ;; let lookup_exn t k = (Elt.value (Hashtbl.find_exn t.table k)).value let mem t k = Hashtbl.mem t.table k (* Note that this is the tail-recursive Core_list.map *) let to_list t = List.map (Doubly_linked.to_list t.queue) ~f:Key_value.value let to_array t = Array.map (Doubly_linked.to_array t.queue) ~f:Key_value.value let for_all t ~f = read t (fun () -> Doubly_linked.for_all t.queue ~f:(fun kv -> f kv.value)) ;; let exists t ~f = read t (fun () -> Doubly_linked.exists t.queue ~f:(fun kv -> f kv.value)) let find_map t ~f = read t (fun () -> Doubly_linked.find_map t.queue ~f:(fun kv -> f kv.value)) ;; let find t ~f = read t (fun () -> Option.map (Doubly_linked.find t.queue ~f:(fun kv -> f kv.value)) ~f:Key_value.value) ;; let enqueue t key value = ensure_can_modify t; if Hashtbl.mem t.table key then `Key_already_present else begin let elt = Doubly_linked.insert_last t.queue { Key_value.key = key; value = value; } in Hashtbl.set t.table ~key ~data:elt; `Ok end ;; exception Enqueue_duplicate_key of Key.t with sexp let enqueue_exn t key value = match enqueue t key value with | `Key_already_present -> raise (Enqueue_duplicate_key key) | `Ok -> () ;; let dequeue_with_key t = ensure_can_modify t; match Doubly_linked.remove_first t.queue with | None -> None | Some kv -> Hashtbl.remove t.table kv.key; Some (kv.key, kv.value) ;; exception Deque_with_key_empty with sexp let dequeue_with_key_exn t = match dequeue_with_key t with | None -> raise Deque_with_key_empty | Some (k, v) -> (k, v) ;; let dequeue t = match dequeue_with_key t with | None -> None | Some (_, v) -> Some v ;; let first_with_key t = match Doubly_linked.first t.queue with | None -> None | Some { key; value; } -> Some (key, value) ;; let first t = match Doubly_linked.first t.queue with | None -> None | Some kv -> Some kv.value ;; exception Deque_empty with sexp let dequeue_exn t = match dequeue t with | None -> raise Deque_empty | Some v -> v ;; let keys t = (* Return the keys in the order of the queue. *) List.map (Doubly_linked.to_list t.queue) ~f:Key_value.key ;; let iteri t ~f = read t (fun () -> Doubly_linked.iter t.queue ~f:(fun kv -> f ~key:kv.key ~data:kv.value)) ;; let iter t ~f = iteri t ~f:(fun ~key:_ ~data -> f data) let foldi t ~init ~f = read t (fun () -> Doubly_linked.fold t.queue ~init ~f:(fun ac kv -> (f ac ~key:kv.key ~data:kv.value))) ;; let fold t ~init ~f = foldi t ~init ~f:(fun ac ~key:_ ~data -> f ac data) let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum m ~fold t ~f let min_elt t ~cmp = Container.min_elt ~fold t ~cmp let max_elt t ~cmp = Container.max_elt ~fold t ~cmp let dequeue_all t ~f = let rec loop () = match dequeue t with | None -> () | Some v -> f v; loop () in loop () let remove t k = ensure_can_modify t; match Hashtbl.find t.table k with | None -> `No_such_key | Some elt -> Doubly_linked.remove t.queue elt; Hashtbl.remove t.table (Elt.value elt).key; `Ok ;; exception Remove_unknown_key of Key.t with sexp let remove_exn t k = ensure_can_modify t; match remove t k with | `No_such_key -> raise (Remove_unknown_key k) | `Ok -> () ;; let replace t k v = ensure_can_modify t; match Hashtbl.find t.table k with | None -> `No_such_key | Some elt -> (Elt.value elt).value <- v; `Ok ;; exception Replace_unknown_key of Key.t with sexp let replace_exn t k v = ensure_can_modify t; match replace t k v with | `No_such_key -> raise (Replace_unknown_key k) | `Ok -> () end core_kernel-113.00.00/src/hash_set.ml000066400000000000000000000120651256461164500172410ustar00rootroot00000000000000module Hashtbl = Core_hashtbl module List = StdLabels.List open Sexplib open Sexplib.Conv open With_return open Result.Export open Hash_set_intf module Binable = Binable0 module Hashable = Hashtbl.Hashable type 'a t = ('a, unit) Hashtbl.t type 'a hash_set = 'a t type 'a elt = 'a module type S = S with type 'a hash_set = 'a t module type S_binable = S_binable with type 'a hash_set = 'a t module Accessors = struct let clear = Hashtbl.clear let length = Hashtbl.length let mem = Hashtbl.mem let is_empty t = Hashtbl.is_empty t let find_map t ~f = with_return (fun r -> Hashtbl.iter t ~f:(fun ~key:elt ~data:_ -> match f elt with | None -> () | Some _ as o -> r.return o); None) ;; let find t ~f = find_map t ~f:(fun a -> if f a then Some a else None) let add t k = Hashtbl.set t ~key:k ~data:() let strict_add t k = if mem t k then Or_error.error_string "element already exists" else begin Hashtbl.set t ~key:k ~data:(); Result.Ok () end ;; let strict_add_exn t k = Or_error.ok_exn (strict_add t k) let remove = Hashtbl.remove let strict_remove t k = if mem t k then begin remove t k; Result.Ok () end else Or_error.error "element not in set" k (Hashtbl.sexp_of_key t) ;; let strict_remove_exn t k = Or_error.ok_exn (strict_remove t k) let fold t ~init ~f = Hashtbl.fold t ~init ~f:(fun ~key ~data:() acc -> f acc key) let iter t ~f = Hashtbl.iter t ~f:(fun ~key ~data:() -> f key) let count t ~f = Container.count ~fold t ~f let sum m t ~f = Container.sum ~fold m t ~f let min_elt t ~cmp = Container.min_elt ~fold t ~cmp let max_elt t ~cmp = Container.max_elt ~fold t ~cmp let to_list = Hashtbl.keys let sexp_of_t sexp_of_e t = sexp_of_list sexp_of_e (to_list t) let to_array t = Array.of_list (to_list t) let exists t ~f = Hashtbl.existsi t ~f:(fun ~key ~data:() -> f key) let for_all t ~f = not (Hashtbl.existsi t ~f:(fun ~key ~data:() -> not (f key))) let equal t1 t2 = Hashtbl.equal t1 t2 (fun () () -> true) let copy t = Hashtbl.copy t let filter t ~f = Hashtbl.filteri t ~f:(fun ~key ~data:() -> f key) let diff t1 t2 = filter t1 ~f:(fun key -> not (Hashtbl.mem t2 key)) let filter_inplace t ~f = let to_remove = fold t ~init:[] ~f:(fun ac x -> if f x then ac else x :: ac) in List.iter to_remove ~f:(fun x -> remove t x) ;; let of_hashtbl_keys hashtbl = Hashtbl.map hashtbl ~f:ignore end include Accessors let create ?growth_allowed ?size ~hashable () = Hashtbl.create ?growth_allowed ?size ~hashable () ;; let of_list ?growth_allowed ?size ~hashable l = let size = match size with Some x -> x | None -> List.length l in let t = Hashtbl.create ?growth_allowed ~size ~hashable () in List.iter l ~f:(fun k -> add t k); t ;; module Creators (Elt : sig type 'a t val hashable : 'a t Hashable.t end) : sig type 'a t_ = 'a Elt.t t val t_of_sexp : (Sexp.t -> 'a Elt.t) -> Sexp.t -> 'a t_ include Creators with type 'a t := 'a t_ with type 'a elt := 'a Elt.t with type ('elt, 'z) create_options := ('elt, 'z) create_options_without_hashable end = struct type 'a t_ = 'a Elt.t t let hashable = Elt.hashable let create ?growth_allowed ?size () = Hashtbl.create ?growth_allowed ~hashable ?size () let of_list ?growth_allowed ?size l = of_list ?growth_allowed ?size ~hashable l let t_of_sexp e_of_sexp sexp = match sexp with | Sexp.Atom _ -> raise (Of_sexp_error (Failure "Hash_set.t_of_sexp requires a list", sexp)) | Sexp.List list -> let t = create ~size:(List.length list) () in List.iter list ~f:(fun sexp -> let e = e_of_sexp sexp in match strict_add t e with | Ok () -> () | Error _ -> raise (Of_sexp_error (Error.to_exn (Error.create "Hash_set.t_of_sexp got a duplicate element" sexp Fn.id), sexp))); t ;; end module Poly = struct type 'a t = 'a hash_set type 'a elt = 'a let hashable = Hashtbl.Poly.hashable include Creators (struct type 'a t = 'a let hashable = hashable end) include Accessors let sexp_of_t = sexp_of_t end module type Elt = Hashtbl.Key module type Elt_binable = Hashtbl.Key_binable module Make (Elt : Elt) = struct module T = Hashtbl.Make (Elt) type elt = Elt.t type 'a hash_set = 'a t type t = elt hash_set type 'a elt_ = elt include Creators (struct type 'a t = Elt.t let hashable = T.hashable end) let sexp_of_t t = Poly.sexp_of_t Elt.sexp_of_t t let t_of_sexp sexp = t_of_sexp Elt.t_of_sexp sexp end module Make_binable (Elt : Elt_binable) = struct include Make (Elt) include Bin_prot.Utils.Make_iterable_binable (struct type t = elt hash_set type el = Elt.t with bin_io let _ = bin_el type acc = t let module_name = Some "Core.Std.Hash_set" let length = length let iter = iter let init size = create ~size () let insert acc v _i = add acc v; acc let finish t = t end) end core_kernel-113.00.00/src/hash_set.mli000066400000000000000000000024211256461164500174050ustar00rootroot00000000000000(* A mutable set of elements *) open Hash_set_intf type 'a t with sexp_of (** We use [with sexp_of] but not [with sexp] because we want people to be explicit about the hash and comparison functions used when creating hashtables. One can use [Hash_set.Poly.t], which does have [with sexp], to use polymorphic comparison and hashing. *) include Creators with type 'a t := 'a t with type 'a elt = 'a with type ('key, 'z) create_options := ('key, 'z) create_options_with_hashable_required include Accessors with type 'a t := 'a t with type 'a elt := 'a elt module type Elt = Core_hashtbl.Key module type Elt_binable = Core_hashtbl.Key_binable module type S = S with type 'a hash_set = 'a t module type S_binable = S_binable with type 'a hash_set = 'a t (** A hash set that uses polymorphic comparison *) module Poly : sig type 'a t with sexp include Creators with type 'a t := 'a t with type 'a elt = 'a with type ('key, 'z) create_options := ('key, 'z) create_options_without_hashable include Accessors with type 'a t := 'a t with type 'a elt := 'a elt end with type 'a t = 'a t module Make (Elt : Elt ) : S with type elt = Elt.t module Make_binable (Elt : Elt_binable) : S_binable with type elt = Elt.t core_kernel-113.00.00/src/hash_set_intf.ml000066400000000000000000000030661256461164500202620ustar00rootroot00000000000000module Binable = Binable0 module type Accessors = sig include Container.Generic val mem : 'a t -> 'a -> bool (** override [Container.Generic.mem] *) val copy : 'a t -> 'a t (** preserves the equality function *) val add : 'a t -> 'a -> unit val strict_add : 'a t -> 'a -> unit Or_error.t val strict_add_exn : 'a t -> 'a -> unit val remove : 'a t -> 'a -> unit val strict_remove : 'a t -> 'a -> unit Or_error.t val strict_remove_exn : 'a t -> 'a -> unit val clear : 'a t -> unit val equal : 'a t -> 'a t -> bool val filter : 'a t -> f:('a -> bool) -> 'a t val diff : 'a t -> 'a t -> 'a t val of_hashtbl_keys : ('a, _) Core_hashtbl.t -> 'a t val filter_inplace : 'a t -> f:('a -> bool) -> unit end type ('key, 'z) create_options_without_hashable = ('key, unit, 'z) Core_hashtbl_intf.create_options_without_hashable type ('key, 'z) create_options_with_hashable_required = ('key, unit, 'z) Core_hashtbl_intf.create_options_with_hashable module type Creators = sig type 'a t type 'a elt type ('a, 'z) create_options val create : ('a, unit -> 'a t) create_options val of_list : ('a, 'a elt list -> 'a t) create_options end module type S = sig type elt type 'a hash_set type t = elt hash_set with sexp type 'a t_ = t type 'a elt_ = elt include Creators with type 'a t := 'a t_ with type 'a elt := 'a elt_ with type ('a, 'z) create_options := ('a, 'z) create_options_without_hashable end module type S_binable = sig include S include Binable.S with type t := t end core_kernel-113.00.00/src/hash_stubs.c000066400000000000000000000010751256461164500174170ustar00rootroot00000000000000#include #include #include /* Final mix and return from the hash.c implementation from INRIA */ #define FINAL_MIX_AND_RETURN(h) \ h ^= h >> 16; \ h *= 0x85ebca6b; \ h ^= h >> 13; \ h *= 0xc2b2ae35; \ h ^= h >> 16; \ return Val_int(h & 0x3FFFFFFFU); CAMLprim value caml_hash_string (value string) { uint32_t h; h = caml_hash_mix_string (0, string); FINAL_MIX_AND_RETURN(h) } CAMLprim value caml_hash_double (value d) { uint32_t h; h = caml_hash_mix_double (0, Double_val(d)); FINAL_MIX_AND_RETURN (h); } core_kernel-113.00.00/src/hashable.ml000066400000000000000000000022031256461164500172030ustar00rootroot00000000000000module Binable = Binable0 module Hashtbl = Core_hashtbl module type S = sig type t val hash : t -> int val compare : t -> t -> int val hashable : t Hashtbl.Hashable.t module Table : Hashtbl .S with type key = t module Hash_set : Hash_set .S with type elt = t module Hash_queue : Hash_queue.S with type Key.t = t end module Make (T : Hashtbl.Key) : S with type t := T.t = struct include T module Table = Hashtbl .Make (T) module Hash_set = Hash_set .Make (T) module Hash_queue = Hash_queue.Make (T) let hashable = Table.hashable end module type S_binable = sig type t val hash : t -> int val hashable : t Hashtbl.Hashable.t module Table : Hashtbl. S_binable with type key = t module Hash_set : Hash_set. S_binable with type elt = t module Hash_queue : Hash_queue.S with type Key.t = t end module Make_binable (T : Hashtbl.Key_binable) : S_binable with type t := T.t = struct module Table = Hashtbl .Make_binable (T) module Hash_set = Hash_set .Make_binable (T) module Hash_queue = Hash_queue.Make (T) include T let hashable = Table.hashable end core_kernel-113.00.00/src/hashtbl_unit_tests.ml000066400000000000000000000161111256461164500213450ustar00rootroot00000000000000open Std_internal module Make (Hashtbl : Core_hashtbl_intf.Hashtbl) = struct let test_data = [("a",1);("b",2);("c",3)] let test_hash = begin let h = Hashtbl.Poly.create () ~size:10 in List.iter test_data ~f:(fun (k,v) -> Hashtbl.set h ~key:k ~data:v ); h end (* This is a very strong notion of equality on hash tables *) let equal t t' equal_data = let subtable t t' = try List.for_all (Hashtbl.keys t) ~f:(fun key -> equal_data (Hashtbl.find_exn t key) (Hashtbl.find_exn t' key)) with | Invalid_argument _ -> false in subtable t t' && subtable t' t TEST "find" = let found = Hashtbl.find test_hash "a" in let not_found = Hashtbl.find test_hash "A" in Hashtbl.invariant test_hash; match found,not_found with | Some _, None -> true | _ -> false ;; TEST_UNIT "add" = let our_hash = Hashtbl.copy test_hash in let duplicate = Hashtbl.add our_hash ~key:"a" ~data:4 in let no_duplicate = Hashtbl.add our_hash ~key:"d" ~data:5 in assert (Hashtbl.find our_hash "a" = Some 1); assert (Hashtbl.find our_hash "d" = Some 5); Hashtbl.invariant our_hash; assert (match duplicate, no_duplicate with | `Duplicate, `Ok -> true | _ -> false) ;; TEST "iter_vals" = let predicted = List.sort ~cmp:Int.descending ( List.map test_data ~f:(fun (_,v) -> v)) in let found = let found = ref [] in Hashtbl.iter_vals test_hash ~f:(fun v -> found := v :: !found); !found |> List.sort ~cmp:Int.descending in List.equal ~equal:Int.equal predicted found ;; TEST_MODULE "of_alist" = struct TEST "size" = let predicted = List.length test_data in let found = Hashtbl.length (Hashtbl.Poly.of_alist_exn test_data) in predicted = found ;; TEST "right keys" = let predicted = List.map test_data ~f:(fun (k,_) -> k) in let found = Hashtbl.keys (Hashtbl.Poly.of_alist_exn test_data) in let sp = List.sort ~cmp:Poly.ascending predicted in let sf = List.sort ~cmp:Poly.ascending found in sp = sf ;; end TEST_MODULE "of_alist_or_error" = struct TEST "unique" = Result.is_ok (Hashtbl.Poly.of_alist_or_error test_data) TEST "duplicate" = Result.is_error (Hashtbl.Poly.of_alist_or_error (test_data @ test_data)) end TEST "size and right keys" = let predicted = List.map test_data ~f:(fun (k,_) -> k) in let found = Hashtbl.keys test_hash in let sp = List.sort ~cmp:Poly.ascending predicted in let sf = List.sort ~cmp:Poly.ascending found in sp = sf ;; TEST "size and right data" = let predicted = List.map test_data ~f:(fun (_,v) -> v) in let found = Hashtbl.data test_hash in let sp = List.sort ~cmp:Poly.ascending predicted in let sf = List.sort ~cmp:Poly.ascending found in sp = sf ;; TEST "map" = let add1 x = x + 1 in let predicted_data = List.sort ~cmp:Poly.ascending (List.map test_data ~f:(fun (k,v) -> (k,add1 v))) in let found_alist = Hashtbl.map test_hash ~f:add1 |> Hashtbl.to_alist |> List.sort ~cmp:Poly.ascending in List.equal predicted_data found_alist ~equal:Poly.equal ;; TEST_UNIT "filter_map" = let f x = Some x in let result = Hashtbl.filter_map test_hash ~f in assert (equal test_hash result Int.(=)); let is_even x = x mod 2 = 0 in let add1_to_even x = if is_even x then Some (x + 1) else None in let predicted_data = List.filter_map test_data ~f:(fun (k,v) -> if is_even v then Some (k, v+1) else None) in let found = Hashtbl.filter_map test_hash ~f:add1_to_even in let found_alist = List.sort ~cmp:Poly.ascending (Hashtbl.to_alist found) in assert (List.equal predicted_data found_alist ~equal:Poly.equal); ;; TEST_UNIT "insert-find-remove" = let t = Hashtbl.Poly.create () ~size:1 in let inserted = ref [] in Random.self_init (); let verify_inserted t = let missing = List.fold !inserted ~init:[] ~f:(fun acc (key, data) -> match Hashtbl.find t key with | None -> `Missing key :: acc | Some d -> if data = d then acc else `Wrong_data (key, data) :: acc) in match missing with | [] -> () | l -> failwiths "some inserts are missing" l <:sexp_of< [`Missing of int | `Wrong_data of int * int ] list>> in let rec loop i t = if i < 2000 then begin let k = Random.int 10_000 in inserted := List.Assoc.add (List.Assoc.remove !inserted k) k i; Hashtbl.set t ~key:k ~data:i; Hashtbl.invariant t; verify_inserted t; loop (i + 1) t end in loop 0 t; List.iter !inserted ~f:(fun (x, _) -> Hashtbl.remove t x; Hashtbl.invariant t; begin match Hashtbl.find t x with | None -> () | Some _ -> failwith (sprintf "present after removal: %d" x) end; inserted := List.Assoc.remove !inserted x; verify_inserted t) ;; TEST_UNIT "clear" = let t = Hashtbl.Poly.create () ~size:1 in let l = List.range 0 100 in let verify_present l = List.for_all l ~f:(Hashtbl.mem t) in let verify_not_present l = List.for_all l ~f:(fun i -> not (Hashtbl.mem t i)) in List.iter l ~f:(fun i -> Hashtbl.set t ~key:i ~data:(i * i)); List.iter l ~f:(fun i -> Hashtbl.set t ~key:i ~data:(i * i)); assert (Hashtbl.length t = 100); assert (verify_present l); Hashtbl.clear t; Hashtbl.invariant t; assert (Hashtbl.length t = 0); assert (verify_not_present l); let l = List.take l 42 in List.iter l ~f:(fun i -> Hashtbl.set t ~key:i ~data:(i * i)); assert (Hashtbl.length t = 42); assert (verify_present l); Hashtbl.invariant t; ;; TEST_UNIT "mem" = let t = Hashtbl.Poly.create () ~size:1 in Hashtbl.invariant t; assert (not (Hashtbl.mem t "Fred")); Hashtbl.invariant t; Hashtbl.set t ~key:"Fred" ~data:"Wilma"; Hashtbl.invariant t; assert (Hashtbl.mem t "Fred"); Hashtbl.invariant t; Hashtbl.remove t "Fred"; Hashtbl.invariant t; assert (not (Hashtbl.mem t "Fred")); Hashtbl.invariant t; ;; TEST_UNIT "exists" = let t = Hashtbl.Poly.create () in assert (not (Hashtbl.exists t ~f:(fun _ -> failwith "can't be called"))); Hashtbl.set t ~key:7 ~data:3; assert (not (Hashtbl.exists t ~f:(Int.equal 4))); Hashtbl.set t ~key:8 ~data:4; assert (Hashtbl.exists t ~f:(Int.equal 4)); Hashtbl.set t ~key:9 ~data:5; assert (Hashtbl.existsi t ~f:(fun ~key ~data -> key + data = 14)) TEST_UNIT "for_all" = let t = Hashtbl.Poly.create () in assert (Hashtbl.for_all t ~f:(fun _ -> failwith "can't be called")); Hashtbl.set t ~key:7 ~data:3; assert (Hashtbl.for_all t ~f:(fun x -> Int.equal x 3)); Hashtbl.set t ~key:8 ~data:4; assert (not (Hashtbl.for_all t ~f:(fun x -> Int.equal x 3))); Hashtbl.set t ~key:9 ~data:5; assert (Hashtbl.for_alli t ~f:(fun ~key ~data -> key - 4 = data)); end module M(S : sig end) = Make(Hashtbl) TEST_MODULE = M(struct end) core_kernel-113.00.00/src/hashtbl_unit_tests.mli000066400000000000000000000000741256461164500215170ustar00rootroot00000000000000module Make (Hashtbl : Core_hashtbl_intf.Hashtbl) : sig end core_kernel-113.00.00/src/heap.ml000066400000000000000000000473521256461164500163670ustar00rootroot00000000000000open Std_internal module Pointer = Pool.Pointer (* This pool holds nodes that would be represented more traditionally as: type 'a t = | Empty | Heap of 'a * 'a t list We will represent them as a left-child, right-sibling tree in a triplet (value * left_child * right_sibling). The left child and all right siblings of the left child form a linked list representing the subheaps of a given heap: A / B -> C -> D -> E -> F / / / G H->I->J K->L *) module Node : sig (* Exposing [private int] is a significant performance improvement, because it allows the compiler to skip the write barrier. *) type 'a t = private int module Pool : sig type 'a node = 'a t type 'a t val create : min_size:int -> 'a t val is_full : 'a t -> bool val length : 'a t -> int val grow : 'a t -> 'a t val copy : 'a t -> 'a node -> ('a -> 'b) -> ('b node * 'b t) end (** [allocate pool v] allocates a new node from the pool with no child or sibling *) val allocate : 'a Pool.t -> 'a -> 'a t (** [free pool t] frees [t] for reuse. It is an error to access [t] after this. *) val free : 'a Pool.t -> 'a t -> unit (** a special [t] that represents the empty node *) val empty : unit -> 'a t val is_empty : 'a t -> bool (** [value_exn pool t] return the value of [t], raise if [is_empty t] *) val value_exn : 'a Pool.t -> 'a t -> 'a (** [add_child pool t ~child] Add a child to [t], preserving existing children as siblings of [child]. [t] and [child] should not be empty and [child] should have no sibling. *) val add_child : 'a Pool.t -> 'a t -> child:'a t -> unit val disconnect_sibling : 'a Pool.t -> 'a t -> 'a t val disconnect_child : 'a Pool.t -> 'a t -> 'a t val child : 'a Pool.t -> 'a t -> 'a t val sibling : 'a Pool.t -> 'a t -> 'a t end = struct type 'a node = ( 'a , 'a node Pointer.t , 'a node Pointer.t ) Pool.Slots.t3 type 'a t = 'a node Pointer.t let empty = Pointer.null let is_empty = Pointer.is_null let value_exn pool t = assert (not (is_empty t)); Pool.get pool t Pool.Slot.t0 ;; let allocate pool value = Pool.new3 pool value (empty ()) (empty ()) let free pool node = Pool.unsafe_free pool node ;; let sibling pool node = Pool.get pool node Pool.Slot.t2 let disconnect_sibling pool node = let sibling = sibling pool node in Pool.set pool node Pool.Slot.t2 (empty ()); sibling ;; let child pool node = Pool.get pool node Pool.Slot.t1 let disconnect_child pool node = let child = child pool node in Pool.set pool node Pool.Slot.t1 (empty ()); child ;; let add_child pool node ~child:new_child = (* assertions we would make, but for speed: assert (not (is_empty node)); assert (not (is_empty new_child)); assert (is_empty (sibling pool new_child)); *) let current_child = disconnect_child pool node in (* add [new_child] to the list of [node]'s children (which may be empty) *) Pool.set pool new_child Pool.Slot.t2 current_child; Pool.set pool node Pool.Slot.t1 new_child; ;; module Pool = struct type 'a t = 'a node Pool.t type nonrec 'a node = 'a node Pointer.t let create (type a) ~min_size:capacity : a t = Pool.create Pool.Slots.t3 ~capacity ~dummy:((Obj.magic () : a), Pointer.null (), Pointer.null ()) ;; let is_full t = Pool.is_full t let length t = Pool.length t let grow t = Pool.grow t let copy t start transform = let t' = create ~min_size:(Pool.capacity t) in let copy_node node to_visit = if is_empty node then (empty (), to_visit) else begin let new_node = allocate t' (transform (value_exn t node)) in let to_visit = (new_node, Pool.Slot.t1, child t node) :: (new_node, Pool.Slot.t2, sibling t node) :: to_visit in (new_node, to_visit) end in let rec loop to_visit = match to_visit with | [] -> () | (node_to_update, slot, node_to_copy) :: rest -> let new_node, to_visit = copy_node node_to_copy rest in Pool.set t' node_to_update slot new_node; loop to_visit in let new_start, to_visit = copy_node start [] in loop to_visit; (new_start, t') ;; end end module T = struct (* Every node input to a function is assumed to have no sibling and any node output from a function will have no sibling. This is because a node is really the head of a node list, but we always want to work with node options, corresponding to the type t defined as type 'a node = Node of 'a * 'a node list type 'a t = 'a node option *) type 'a t = { (* cmp is placed first to short-circuit polymorphic compare *) cmp : 'a -> 'a -> int; mutable pool : 'a Node.Pool.t; (* invariant: [heap] never has a sibling *) mutable heap : 'a Node.t; } let create ?(min_size = 1) ~cmp () = { cmp; pool = Node.Pool.create ~min_size; heap = Node.empty (); } ;; let copy t = let heap, pool = Node.Pool.copy t.pool t.heap ident in { cmp = t.cmp; pool; heap; } ;; let allocate t v = if Node.Pool.is_full t.pool then begin t.pool <- Node.Pool.grow t.pool; end; Node.allocate t.pool v ;; (* translation: match heap1, heap2 with | None, h | h, None -> h | Some (Node (v1, children1)), Some (Node (v2, children2)) -> if v1 < v2 then Some (Node (v1, heap2 :: children1)) else Some (Node (v2, heap1 :: children2)) *) let merge t heap1 heap2 = if Node.is_empty heap1 then heap2 else if Node.is_empty heap2 then heap1 else let add_child t heap ~child = Node.add_child t.pool heap ~child; heap in let v1 = Node.value_exn t.pool heap1 in let v2 = Node.value_exn t.pool heap2 in if t.cmp v1 v2 < 0 then add_child t heap1 ~child:heap2 else add_child t heap2 ~child:heap1 ;; let top_exn t = if Node.is_empty t.heap then failwith "Heap.top_exn called on an empty heap" else Node.value_exn t.pool t.heap ;; let top t = try Some (top_exn t) with _ -> None let add t v = t.heap <- merge t t.heap (allocate t v) ;; (* [merge_pairs] takes a list of heaps and merges consecutive pairs, reducing the list of length n to n/2. Then it merges the merged pairs into a single heap. One intuition is that this is somewhat like building a single level of a binary tree. The output heap does not contain the value that was at the root of the input heap. *) (* translation: match t.heap with | Node (_, children) -> let rec loop acc = function | [] -> acc | [head] -> head :: acc | head :: next1 :: next2 -> loop (merge head next1 :: acc) next2 in match loop [] children with | [] -> None | [h] -> Some h | x :: xs -> Some (List.fold xs ~init:x ~f:merge) *) let merge_pairs t = let rec loop acc head = if Node.is_empty head then acc else let next1 = Node.disconnect_sibling t.pool head in if Node.is_empty next1 then head :: acc else let next2 = Node.disconnect_sibling t.pool next1 in loop (merge t head next1 :: acc) next2 in let head = Node.disconnect_child t.pool t.heap in match loop [] head with | [] -> Node.empty () | [h] -> h | x :: xs -> List.fold xs ~init:x ~f:(fun acc heap -> merge t acc heap) ;; let remove_top t = if not (Node.is_empty t.heap) then begin let current_heap = t.heap in t.heap <- merge_pairs t; Node.free t.pool current_heap end ;; let pop_exn t = let r = top_exn t in remove_top t; r ;; let pop t = try Some (pop_exn t) with _ -> None let pop_if t f = match top t with | None -> None | Some v when f v -> remove_top t; Some v | Some _ -> None ;; (* pairing heaps are not balanced trees, and therefore we can't rely on a balance property to stop ourselves from overflowing the stack. *) let fold t ~init ~f = let pool = t.pool in let rec loop acc to_visit = match to_visit with | [] -> acc | node :: rest -> if Node.is_empty node then loop acc rest else begin let to_visit = (Node.sibling pool node) :: (Node.child pool node) :: rest in loop (f acc (Node.value_exn pool node)) to_visit end in loop init [t.heap] ;; (* almost identical to fold, copied for speed purposes *) let iter t ~f = let pool = t.pool in let rec loop to_visit = match to_visit with | [] -> () | node :: rest -> if Node.is_empty node then loop rest else begin f (Node.value_exn pool node); let to_visit = (Node.sibling pool node) :: (Node.child pool node) :: rest in loop to_visit end in loop [t.heap] ;; module C = Container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter end) (* we can do better than the O(n) of [C.length] *) let length t = Node.Pool.length t.pool let is_empty t = Node.is_empty t.heap let mem = C.mem let exists = C.exists let for_all = C.for_all let count = C.count let sum = C.sum let find = C.find let find_map = C.find_map let to_list = C.to_list let to_array = C.to_array let min_elt = C.min_elt let max_elt = C.max_elt let of_array arr ~cmp = let t = create ~min_size:(Array.length arr) ~cmp () in Array.iter arr ~f:(fun v -> add t v); t ;; let of_list l ~cmp = of_array (Array.of_list l) ~cmp let sexp_of_t f t = Array.sexp_of_t f (to_array t) TEST_MODULE = struct let data = [ 0; 1; 2; 3; 4; 5; 6; 7 ] let t = of_list data ~cmp:Int.compare (* pop the zero at the top to force some heap structuring. This does not touch the sum. *) let _ = pop t let list_sum = List.fold data ~init:0 ~f:(fun sum v -> sum + v) let heap_fold_sum = fold t ~init:0 ~f:(fun sum v -> sum + v) let heap_iter_sum = let r = ref 0 in iter t ~f:(fun v -> r := !r + v); !r TEST = Int.(=) list_sum heap_fold_sum TEST = Int.(=) list_sum heap_iter_sum end end module Removable = struct module Elt = struct (* We could use an extra word to hold a pointer/representative id of the heap this token belongs to to prevent using this token with the wrong heap in the remove/update functions below. It's (currently) deemed not worth the cost in memory/speed. *) type 'a t = 'a option ref with sexp_of let create v = ref (Some v) let value_exn t = Option.value_exn !t end type 'a t = { heap : 'a Elt.t T.t; mutable length : int; } with sexp_of let remove t token = match !token with | None -> () | Some _ -> token := None; t.length <- t.length - 1 ;; let augment_cmp cmp = (fun v1 v2 -> match !v1, !v2 with | None, None -> 0 | None, Some _ -> -1 | Some _, None -> 1 | Some v1, Some v2 -> cmp v1 v2) ;; let create ?min_size ~cmp () = let cmp = augment_cmp cmp in { length = 0; heap = T.create ?min_size ~cmp () } ;; let copy t = let current_heap = t.heap in let replace_token v = ref !v in let heap, pool = Node.Pool.copy current_heap.T.pool current_heap.T.heap replace_token in {t with heap = {T.cmp = current_heap.T.cmp; pool; heap}} ;; let add_removable t v = let token = Elt.create v in T.add t.heap token; t.length <- t.length + 1; token ;; let update t token v = remove t token; add_removable t v ;; let add t v = ignore (add_removable t v : _ Elt.t) let rec clear_deleted_tokens t = if not (Node.is_empty t.heap.T.heap) then match !(T.top_exn t.heap) with | Some _ -> () | None -> T.remove_top t.heap; clear_deleted_tokens t; ;; let fold t ~init ~f = T.fold t.heap ~init ~f:(fun acc token -> match !token with | None -> acc | Some v -> f acc v) ;; let iter t ~f = T.iter t.heap ~f:(fun token -> match !token with | None -> () | Some v -> f v) ;; let find_elt t ~f = T.find t.heap ~f:(fun token -> match !token with | None -> false | Some v -> f v) ;; module C = Container.Make (struct type nonrec 'a t = 'a t let fold = fold let iter = `Custom iter end) let length t = t.length let is_empty t = t.length = 0 let to_array = C.to_array let to_list = C.to_list let find_map = C.find_map let find = C.find let count = C.count let sum = C.sum let for_all = C.for_all let exists = C.exists let mem = C.mem let min_elt = C.min_elt let max_elt = C.max_elt let of_array arr ~cmp = let t = create ~min_size:(Array.length arr) ~cmp () in Array.iter arr ~f:(fun v -> add t v); t ;; let of_list l ~cmp = of_array (Array.of_list l) ~cmp let top_exn t = clear_deleted_tokens t; Elt.value_exn (T.top_exn t.heap) let top t = try Some (top_exn t) with _ -> None let pop_exn t = clear_deleted_tokens t; let token = T.pop_exn t.heap in let v = Elt.value_exn token in remove t token; v ;; let pop t = try Some (pop_exn t) with _ -> None let remove_top t = clear_deleted_tokens t; begin match T.top t.heap with | Some _ -> ignore (pop_exn t) | None -> () end; ;; let pop_if t f = clear_deleted_tokens t; match T.pop_if t.heap (fun v -> f (Elt.value_exn v)) with | None -> None | Some token -> let v = Elt.value_exn token in remove t token; Some v ;; end include T TEST_MODULE = struct module type Heap_intf = sig type 'a t with sexp_of val create : cmp:('a -> 'a -> int) -> 'a t val add : 'a t -> 'a -> unit val pop : 'a t -> 'a option val length : 'a t -> int val top : 'a t -> 'a option val remove_top : 'a t -> unit val to_list : 'a t -> 'a list end module That_heap : Heap_intf = struct type 'a t = { cmp : 'a -> 'a -> int; mutable heap : 'a list; } let sexp_of_t sexp_of_v t = List.sexp_of_t sexp_of_v t.heap let create ~cmp = { cmp; heap = [] } let add t v = t.heap <- List.sort ~cmp:t.cmp (v :: t.heap) let pop t = match t.heap with | [] -> None | x :: xs -> t.heap <- xs; Some x ;; let length t = List.length t.heap let top t = List.hd t.heap let remove_top t = match t.heap with [] -> () | _ :: xs -> t.heap <- xs let to_list t = t.heap end module This_heap : Heap_intf = struct type nonrec 'a t = 'a t with sexp_of let create ~cmp = create ~cmp () let add = add let pop = pop let length = length let top = top let remove_top = remove_top let to_list = to_list end let this_to_string this = Sexp.to_string (This_heap.sexp_of_t Int.sexp_of_t this) let that_to_string that = Sexp.to_string (That_heap.sexp_of_t Int.sexp_of_t that) let length_check (t_a, t_b) = let this_len = This_heap.length t_a in let that_len = That_heap.length t_b in if this_len <> that_len then failwithf "error in length: %i (for %s) <> %i (for %s)" this_len (this_to_string t_a) that_len (that_to_string t_b) () ;; let create () = let cmp = Int.compare in (This_heap.create ~cmp, That_heap.create ~cmp) ;; let add (this_t, that_t) v = This_heap.add this_t v; That_heap.add that_t v; length_check (this_t, that_t) ;; let pop (this_t, that_t) = let res1 = This_heap.pop this_t in let res2 = That_heap.pop that_t in if res1 <> res2 then failwithf "pop results differ (%s, %s)" (Option.value ~default:"None" (Option.map ~f:Int.to_string res1)) (Option.value ~default:"None" (Option.map ~f:Int.to_string res2)) () ;; let top (this_t, that_t) = let res1 = This_heap.top this_t in let res2 = That_heap.top that_t in if res1 <> res2 then failwithf "top results differ (%s, %s)" (Option.value ~default:"None" (Option.map ~f:Int.to_string res1)) (Option.value ~default:"None" (Option.map ~f:Int.to_string res2)) () ;; let remove_top (this_t, that_t) = This_heap.remove_top this_t; That_heap.remove_top that_t; length_check (this_t, that_t) ;; let internal_check (this_t, that_t) = let this_list = List.sort ~cmp:Int.compare (This_heap.to_list this_t) in let that_list = List.sort ~cmp:Int.compare (That_heap.to_list that_t) in assert (this_list = that_list) ;; let test_dual_ops () = let t = create () in let rec loop ops = if ops = 0 then () else begin let r = Random.int 100 in begin if r < 40 then add t (Random.int 100_000) else if r < 70 then pop t else if r < 80 then top t else if r < 90 then remove_top t else internal_check t end; loop (ops - 1) end in loop 1_000 ;; TEST_UNIT = test_dual_ops () end let test_copy () = let sum t = fold t ~init:0 ~f:(fun acc i -> acc + i) in let t = create ~cmp:Int.compare () in for i = 1 to 100 do add t i; if i % 10 = 0 (* We need to pop from time to time to trigger the amortized tree reorganizations. If we don't do this the resulting structure is just a linked list and the copy function is not flexed as completely as it should be. *) then begin ignore (pop t); add t i end done; let t' = copy t in assert (sum t = sum t'); assert (to_list t = to_list t'); add t (-100); assert (sum t = sum t' - 100); ;; TEST_UNIT = test_copy () let test_removable_copy () = let sum t = Removable.fold t ~init:0 ~f:(fun acc i -> acc + i) in let t = Removable.create ~cmp:Int.compare () in for i = 1 to 99 do Removable.add t i; if i % 10 = 0 (* We need to pop from time to time to trigger the amortized tree reorganizations. If we don't do this the resulting structure is just a linked list and the copy function is not flexed as completely as it should be. *) then begin ignore (Removable.pop t); Removable.add t i end done; let token = Removable.add_removable t 100 in let t' = Removable.copy t in assert (sum t = sum t'); Removable.remove t token; assert (sum t = sum t' - 100); ;; TEST_UNIT = test_removable_copy () let test_removal () = let t = Removable.create ~cmp:Int.compare () in let tokens = ref [] in for i = 1 to 10_000 do tokens := Removable.add_removable t i :: !tokens; done; List.iter !tokens ~f:(fun token -> if Removable.Elt.value_exn token % 2 <> 0 then Removable.remove t token); let rec loop count = match Removable.pop t with | None -> assert (count = 10_000 / 2); | Some v -> assert ((1 + count) * 2 = v); loop (count + 1) in loop 0 ;; TEST_UNIT = test_removal () let test_ordering () = let t = create ~cmp:Int.compare () in for _i = 1 to 10_000 do add t (Random.int 100_000); done; let rec loop last = match pop t with | None -> () | Some v -> assert (v >= last); loop v in loop (-1) ;; TEST_UNIT = test_ordering () TEST_UNIT = ignore (of_array [| |] ~cmp:Int.compare); BENCH_INDEXED "pop_insert_with_existing_heap" initial_size [1; 100; 10_000; 1_000_000] = let a = Array.init initial_size ~f:(fun _ -> Random.int 100_000) in let h1 = of_array ~cmp:Int.compare a in (fun () -> let e = pop_exn h1 in add h1 e; ) core_kernel-113.00.00/src/heap.mli000066400000000000000000000034171256461164500165320ustar00rootroot00000000000000(** Heap implementation based on a pairing-heap. This heap implementations supports an arbitrary element type, via a comparison function. If you need a heap with elements ordered by integers, then it may be more efficient to use a [Timing_wheel.Priority_queue], which is a heap implementation specialized to integer keys, and with some other performance differences and usage restrictions. *) include Heap_intf.S (** Removable augments a heap with the ability to remove elements from the heap in lg(n) (amortized) time at any point after they have been added. Elements within a Removable heap consume 4 words more memory and all heap operations will be somewhat slower. *) module Removable : sig include Heap_intf.S module Elt : sig type 'a t with sexp_of (** [value_exn t] return the value in the heap controlled by this token if the value is still in the heap. Raise otherwise. *) val value_exn : 'a t -> 'a end (** [add_removable t v] adds [v] to [t], returning a token that can be used to delete [v] from [t] in lg(n) amortized time. *) val add_removable : 'a t -> 'a -> 'a Elt.t (** If [t] and [token] are mismatched then behavior is undefined. [remove] may safely be called on a token more than once. This doesn't free all the memory associated with the Elt until some number of [pop] operations later -- see Heap_intf for details. *) val remove : 'a t -> 'a Elt.t -> unit (** [update t token v] is shorthand for [remove t token; add_removable t v] *) val update : 'a t -> 'a Elt.t -> 'a -> 'a Elt.t (** [find_elt t ~f]. If [f] is true for some element in [t], return a [Elt.t] for that element. This operation is O(n). *) val find_elt : 'a t -> f:('a -> bool) -> 'a Elt.t option end core_kernel-113.00.00/src/heap_block.ml000066400000000000000000000007321256461164500175300ustar00rootroot00000000000000type 'a t = 'a with sexp_of external is_heap_block : Obj.t -> bool = "core_heap_block_is_heap_block" "noalloc" let is_ok v = is_heap_block (Obj.repr v) let create v = if is_ok v then Some v else None let create_exn v = if is_ok v then v else failwith "Heap_block.create_exn called with non heap block" ;; let value t = t let bytes_per_word = Word_size.(num_bits word_size) / 8 let bytes (type a) (t : a t) = (Obj.size (Obj.repr (t : a t)) + 1) * bytes_per_word core_kernel-113.00.00/src/heap_block.mli000066400000000000000000000032441256461164500177020ustar00rootroot00000000000000(** A heap block is a value that is guaranteed to live on the OCaml heap, and is hence guaranteed to be usable with finalization or in a weak pointer. It is an abstract type so we can use the type system to guarantee that the values we put in weak pointers and use with finalizers are heap blocks. Some examples of values that are not heap-allocated are integers, constant constructors, booleans, the empty array, the empty list, the unit value. The exact list of what is heap-allocated or not is implementation-dependent. Some constant values can be heap-allocated but never deallocated during the lifetime of the program, for example a list of integer constants; this is also implementation-dependent. You should also be aware that compiler optimizations may duplicate some immutable values, for example floating-point numbers when stored into arrays; thus they can be finalized and collected while another copy is still in use by the program. The results of calling {!String.make}, {!String.create}, {!Array.make}, and {!Pervasives.ref} are guaranteed to be heap-allocated and non-constant except when the length argument is [0]. *) type +'a t = private 'a with sexp_of (** [create v] returns [Some t] if [v] is a heap block, where [t] is physically equal to [v] *) val create : 'a -> 'a t option val create_exn : 'a -> 'a t (** [value t] returns the value that is physically equal to [t] *) val value : 'a t -> 'a (** [bytes t] returns the number of bytes on the heap taken by heap block [t], including the header. This is just the space for the single block, not anything it points to. *) val bytes : _ t -> int core_kernel-113.00.00/src/heap_block_stubs.c000066400000000000000000000020531256461164500205600ustar00rootroot00000000000000#include "config.h" #include #define In_heap 1 #define In_young 2 /* copied from byterun/memory.h */ #ifdef JSC_ARCH_SIXTYFOUR /* 64 bits: Represent page table as a sparse hash table */ int caml_page_table_lookup(void * addr); #define Classify_addr(a) (caml_page_table_lookup((void *)(a))) #else /* 32 bits: Represent page table as a 2-level array */ #define Pagetable2_log 11 #define Pagetable2_size (1 << Pagetable2_log) #define Pagetable1_log (Page_log + Pagetable2_log) #define Pagetable1_size (1 << (32 - Pagetable1_log)) CAMLextern unsigned char * caml_page_table[Pagetable1_size]; #define Pagetable_index1(a) (((uintnat)(a)) >> Pagetable1_log) #define Pagetable_index2(a) \ ((((uintnat)(a)) >> Page_log) & (Pagetable2_size - 1)) #define Classify_addr(a) \ caml_page_table[Pagetable_index1(a)][Pagetable_index2(a)] #endif #define Is_in_heap_or_young(a) (Classify_addr(a) & (In_heap | In_young)) CAMLprim value core_heap_block_is_heap_block(value v) { return (Is_block(v) && Is_in_heap_or_young(v)) ? Val_true : Val_false; } core_kernel-113.00.00/src/heap_intf.ml000066400000000000000000000052351256461164500174010ustar00rootroot00000000000000module type S = sig (** of_sexp and bin_io functions aren't supplied for heaps due to the difficulties in reconstructing the correct comparison function when de-serializing. *) type 'a t with sexp_of (** Mutation of the heap during iteration is not supported, but there is no check to prevent it. The behavior of a heap that is mutated during iteration is undefined. *) include Container.S1 with type 'a t := 'a t (** Even though these two functions are part of Container.S1, they are documented separately to make sure there is no confusion. They are independent of the comparison function used to order the heap. Instead, a traversal of the entire structure is done using the provided [cmp] function to find a min or max. If you want to access the smallest element of the heap according to the heap's comparison function in constant time, you should use [top]. *) val min_elt : 'a t -> cmp:('a -> 'a -> int) -> 'a option val max_elt : 'a t -> cmp:('a -> 'a -> int) -> 'a option (** [create ?min_size ~cmp] returns a new min-heap that can store [min_size] elements without reallocations, using ordering function [cmp]. The top of the heap is the smallest element as determined by the provided comparison function. In particular, if [cmp x y < 0] then [x] will be "on top of" [y] in the heap. Memory use is surprising in two ways: 1. The underlying pool never shrinks, so current memory use will at least be proportional to the largest number of elements that the heap has ever held. 2. Not all the memory is freed upon [remove], but rather after some number of subsequent [pop] operations. Alternating [add] and [remove] operations can therefore use unbounded memory. *) val create : ?min_size : int -> cmp:('a -> 'a -> int) -> unit -> 'a t (** [min_size] (see [create]) will be set to the size of the input array or list. *) val of_array : 'a array -> cmp:('a -> 'a -> int) -> 'a t val of_list : 'a list -> cmp:('a -> 'a -> int) -> 'a t (** returns the top (i.e., smallest) element of the heap *) val top : 'a t -> 'a option val top_exn : 'a t -> 'a val add : 'a t -> 'a -> unit (** [remove_top t] does nothing if [t] is empty *) val remove_top : _ t -> unit (** This removes and returns the top (i.e. least) element *) val pop : 'a t -> 'a option val pop_exn : 'a t -> 'a (** [pop_if t cond] returns [Some top_element] of [t] if it satisfies condition [cond], removing it, or [None] in any other case. *) val pop_if : 'a t -> ('a -> bool) -> 'a option (** [copy t] returns a shallow copy *) val copy : 'a t -> 'a t end core_kernel-113.00.00/src/hex_lexer.mll000066400000000000000000000005371256461164500176030ustar00rootroot00000000000000{ type result = | Neg of string | Pos of string } let hex_digit = ['0' - '9' 'A' - 'F' 'a' - 'f'] let body = (hex_digit (hex_digit | '_')*) as body let body_with_suffix = '0' ['X' 'x'] body let pos = body_with_suffix let neg = '-' body_with_suffix rule parse_hex = parse | neg { Neg body } | pos { Pos body } core_kernel-113.00.00/src/host_and_port.ml000066400000000000000000000017741256461164500203130ustar00rootroot00000000000000open Std_internal module Stable = struct module V1 = struct type t = string * int with sexp, bin_io, compare end end module T = struct include Stable.V1 let hash = Hashtbl.hash end include T let create ~host ~port = (host, port) let host = fst let port = snd let tuple t = t let to_string (host, port) = sprintf "%s:%d" host port let of_string s = match String.split s ~on:':' with | [host; port] -> let port = try Int.of_string port with _exn -> failwithf "Host_and_port.of_string: bad port: %s" s () in host, port | _ -> failwithf "Host_and_port.of_string: %s" s () include Pretty_printer.Register (struct type nonrec t = t let to_string = to_string let module_name = "Core_kernel.Std.Host_and_port" end) include (Hashable.Make_binable (T) : Hashable.S_binable with type t := t) include Comparable.Make_binable (T) let t_of_sexp = function | Sexp.Atom s as sexp -> (try of_string s with Failure err -> of_sexp_error err sexp) | sexp -> t_of_sexp sexp core_kernel-113.00.00/src/host_and_port.mli000066400000000000000000000004301256461164500204500ustar00rootroot00000000000000open Std_internal type t val create : host:string -> port:int -> t val host : t -> string val port : t -> int val tuple : t -> string * int include Identifiable with type t := t module Stable : sig module V1 : sig type nonrec t = t with sexp, bin_io, compare end end core_kernel-113.00.00/src/identifiable.ml000066400000000000000000000062731256461164500200660ustar00rootroot00000000000000module Binable = Binable0 module Map = Core_map module Sexp = Sexplib.Sexp let failwiths = Error.failwiths module type S = sig type t with bin_io, sexp include Stringable.S with type t := t include Comparable.S_binable with type t := t include Hashable .S_binable with type t := t include Pretty_printer.S with type t := t end module Make (T : sig type t with bin_io, compare, sexp include Stringable.S with type t := t val hash : t -> int val module_name : string end) = struct include T include Comparable.Make_binable (T) include Hashable .Make_binable (T) include Pretty_printer.Register (T) end (* The unit test below checks that for a call to [Identifiable.Make], the functions in the resulting module call the functions in the argument module the correct number of times. *) TEST_MODULE = struct open Sexplib.Conv module Counter = struct type t = | Compare | Hash | Of_string | Sexp_of_t | T_of_sexp | To_string with compare, sexp end open Counter module Counts = struct module Map = Map.Make (Counter) type t = int Map.t ref with sexp_of let actual = ref Map.empty let expected = ref Map.empty let incr ?(by = 1) t counter = t := Map.change !t counter (function None -> Some by | Some i -> Some (i + by)) ;; let check location = if not (Map.equal (=) !actual !expected) then failwiths "mismatch" (location, `actual actual, `expected expected) <:sexp_of< Source_code_position0.t_hum * [ `actual of t ] * [ `expected of t ] >> ;; end module T = struct let module_name = "Core.Std.Identifiable.T" type t = A | B with bin_io, compare, sexp let hash (t : t) = Hashtbl.hash t include Sexpable.To_stringable (struct type nonrec t = t with sexp end) let incr ?by counter = Counts.incr Counts.actual counter ?by let compare t1 t2 = incr Compare; compare t1 t2 let hash t = incr Hash; hash t let sexp_of_t t = incr Sexp_of_t; sexp_of_t t let t_of_sexp t = incr T_of_sexp; t_of_sexp t let of_string t = incr Of_string; of_string t let to_string t = incr To_string; to_string t end module Id = Make (T) let poly_equal = (=) let int_equal (i1 : int) i2 = poly_equal i1 i2 TEST_UNIT = let open T in let open Id in let check = Counts.check in let incr ?by counter = Counts.incr Counts.expected counter ?by in check _here_; ignore (to_string A : string); incr To_string; check _here_; ignore (of_string "A" : t); incr Of_string; check _here_; ignore (t_of_sexp (Sexp.of_string "A") : t); incr T_of_sexp; check _here_; ignore (sexp_of_t A : Sexp.t); incr Sexp_of_t; check _here_; assert (int_equal (compare A A) 0); incr Compare; check _here_; assert (int_equal (compare A B) (-1)); incr Compare; check _here_; assert (int_equal (compare B A) 1); incr Compare; check _here_; ignore (not (int_equal (hash A) (hash B))); incr Hash ~by:2; check _here_; let bigstring = Binable.to_bigstring (module T) A in check _here_; assert (poly_equal A (Binable.of_bigstring (module T) bigstring)); check _here_; ;; end core_kernel-113.00.00/src/identifiable.mli000066400000000000000000000016061256461164500202320ustar00rootroot00000000000000(** a signature for opaque identifier types. *) module type S = sig type t with bin_io, sexp include Stringable.S with type t := t include Comparable.S_binable with type t := t include Hashable.S_binable with type t := t include Pretty_printer.S with type t := t end (** Used for making an Identifiable module. Here's an example. {[ module Id = struct module T = struct type t = A | B with bin_io, compare, sexp let hash (t : t) = Hashtbl.hash t include Sexpable.To_stringable (struct type nonrec t = t with sexp end) end include T include Identifiable.Make (T) end ]} *) module Make (M : sig type t with bin_io, compare, sexp include Stringable.S with type t := t val hash : t -> int val module_name : string (** for registering the pretty printer *) end) : S with type t := M.t core_kernel-113.00.00/src/in_channel.ml000066400000000000000000000044441256461164500175430ustar00rootroot00000000000000module String = Core_string type t = in_channel let seek = Pervasives.LargeFile.seek_in let pos = Pervasives.LargeFile.pos_in let length = Pervasives.LargeFile.in_channel_length let stdin = Pervasives.stdin let create ?(binary = true) file = let flags = [Open_rdonly] in let flags = if binary then Open_binary :: flags else flags in open_in_gen flags 0o000 file ;; let close = Pervasives.close_in let with_file ?binary file ~f = Exn.protectx (create ?binary file) ~f ~finally:close let may_eof f = try Some (f ()) with End_of_file -> None let input t ~buf ~pos ~len = Pervasives.input t buf pos len let really_input t ~buf ~pos ~len = may_eof (fun () -> Pervasives.really_input t buf pos len) let input_byte t = may_eof (fun () -> Pervasives.input_byte t) let input_char t = may_eof (fun () -> Pervasives.input_char t) let input_binary_int t = may_eof (fun () -> Pervasives.input_binary_int t) let unsafe_input_value t = may_eof (fun () -> Pervasives.input_value t) let set_binary_mode = Pervasives.set_binary_mode_in let input_all t = (* We use 65536 because that is the size of OCaml's IO buffers. *) let buf_size = 65536 in let buf = String.create buf_size in let buffer = Buffer.create buf_size in let rec loop () = let len = input t ~buf ~pos:0 ~len:(String.length buf) in if len > 0 then begin Buffer.add_substring buffer buf 0 len; loop (); end in loop (); Buffer.contents buffer; ;; let input_line ?(fix_win_eol = true) t = match may_eof (fun () -> Pervasives.input_line t) with | None -> None | Some line -> let remove_trailing_return = fix_win_eol && String.length line > 0 && String.nget line (-1) = '\r' in if remove_trailing_return then Some (String.slice line 0 (-1)) else Some line ;; let fold_lines ?fix_win_eol t ~init ~f = let rec loop ac = match input_line ?fix_win_eol t with | None -> ac | Some line -> loop (f ac line) in loop init ;; let input_lines ?fix_win_eol t = List.rev (fold_lines ?fix_win_eol t ~init:[] ~f:(fun lines line -> line :: lines)) ;; let iter_lines ?fix_win_eol t ~f = fold_lines ?fix_win_eol t ~init:() ~f:(fun () line -> f line) ;; let read_lines fname = with_file fname ~f:input_lines let read_all fname = with_file fname ~f:input_all core_kernel-113.00.00/src/in_channel.mli000066400000000000000000000052571256461164500177170ustar00rootroot00000000000000(** [In_channel] collects all of the pervasive functions that work on in_channels. * It adds some new functions (like [input_all] and [input_lines]). * It names things using the fact that there is no worry about toplevel name conflicts (since we are in a module). * It uses labelled arguments. * It returns an option rather than raising End_of_file. Note that an [in_channel] is a custom block with a finalizer, and so is allocated directly to the major heap. Creating a lot of in_channels can result in many major collections and poor performance. *) type t = in_channel val stdin : t (** Channels are opened in binary mode iff [binary] is true. This only has an effect on Windows. *) val create : ?binary:bool (** defaults to [true] *) -> string -> t (** [with_file ~f fname] executes [~f] on the open channel from [fname], and closes it afterwards. *) val with_file : ?binary:bool (** defaults to [true] *) -> string -> f:(t -> 'a) -> 'a (** [close t] closes t, and may raise an exception. *) val close : t -> unit val input : t -> buf:string -> pos:int -> len:int -> int val really_input : t -> buf:string -> pos:int -> len:int -> unit option val input_byte : t -> int option val input_char : t -> char option val input_binary_int : t -> int option val unsafe_input_value : t -> _ option (* Ocaml's built-in marshal format *) val input_all : t -> string (** [input_line ?fix_win_eol t] reads a line from [t] and returns it, without the newline ("\n") character at the end, and, if [fix_win_eol] the trailing "\r\n" is dropped. *) val input_line : ?fix_win_eol:bool (** defaults to [true] *) -> t -> string option (** [fold_lines ?fix_win_eol t ~init ~f] folds over the lines read from [t] using [input_line]. Lines are provided to [f] in the order they are found in the file. *) val fold_lines : ?fix_win_eol:bool (** defaults to [true] *) -> t -> init:'a -> f:('a -> string -> 'a) -> 'a (** Completely reads an input channel and returns the results as a list of strings. Each line in one string. *) val input_lines : ?fix_win_eol:bool (** defaults to [true] *) -> t -> string list (** [iter_lines ?fix_win_eol t ~f] applies [f] to each line read from [t] using [input_line]. *) val iter_lines : ?fix_win_eol:bool (** defaults to [true] *) -> t -> f:(string -> unit) -> unit val seek : t -> int64 -> unit val pos : t -> int64 val length : t -> int64 val set_binary_mode : t -> bool -> unit (** [read_lines filename] Opens filename, reads all lines, and closes the file. *) val read_lines : string -> string list (** [read_all filename] Opens filename, reads all input, and closes the file. *) val read_all : string -> string core_kernel-113.00.00/src/info.ml000066400000000000000000000265361256461164500164060ustar00rootroot00000000000000(* This module is trying to minimize dependencies on modules in Core, so as to allow [Info], [Error], and [Or_error] to be used in is many places places as possible. Please avoid adding new dependencies. *) open Sexplib.Std open Bin_prot.Std module Binable = Binable0 module Conv = Sexplib.Conv module List = Core_list module Sexp = struct include Sexplib.Sexp include (struct type t = Sexplib.Sexp.t = Atom of string | List of t list with bin_io, compare end : sig type t with bin_io, compare end with type t := t) end type sexp = Sexp.t = Atom of string | List of sexp list (* constructor import *) with compare module Binable_exn = struct module Stable = struct module V1 = struct module T = struct type t = exn with sexp_of end include T include Binable.Of_binable (Sexp) (struct include T exception Exn of Sexp.t (* We install a custom exn-converter rather than use [exception Exn of t with sexp] to eliminate the extra wrapping of "(Exn ...)". *) let () = Sexplib.Conv.Exn_converter.add_auto (Exn (Atom "