pax_global_header00006660000000000000000000000064142027330520014510gustar00rootroot0000000000000052 comment=001649fb6b33a2f2cf5b86104575357cad65f93e base_bigstring-0.15.0/000077500000000000000000000000001420273305200145555ustar00rootroot00000000000000base_bigstring-0.15.0/.gitignore000066400000000000000000000000411420273305200165400ustar00rootroot00000000000000_build *.install *.merlin _opam base_bigstring-0.15.0/CONTRIBUTING.md000066400000000000000000000044101420273305200170050ustar00rootroot00000000000000This repository contains open source software that is developed and maintained by [Jane Street][js]. Contributions to this project are welcome and should be submitted via GitHub pull requests. Signing contributions --------------------- We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [dco]: http://developercertificate.org/ [js]: https://opensource.janestreet.com/ base_bigstring-0.15.0/LICENSE.md000066400000000000000000000021351420273305200161620ustar00rootroot00000000000000The MIT License Copyright (c) 2019--2022 Jane Street Group, LLC Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. base_bigstring-0.15.0/Makefile000066400000000000000000000004031420273305200162120ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall install clean: dune clean .PHONY: default install uninstall reinstall clean base_bigstring-0.15.0/base_bigstring.opam000066400000000000000000000014221420273305200204140ustar00rootroot00000000000000opam-version: "2.0" version: "v0.15.0" maintainer: "Jane Street developers" authors: ["Jane Street Group, LLC"] homepage: "https://github.com/janestreet/base_bigstring" bug-reports: "https://github.com/janestreet/base_bigstring/issues" dev-repo: "git+https://github.com/janestreet/base_bigstring.git" doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/base_bigstring/index.html" license: "MIT" build: [ ["dune" "build" "-p" name "-j" jobs] ] depends: [ "ocaml" {>= "4.08.0"} "base" {>= "v0.15" & < "v0.16"} "int_repr" {>= "v0.15" & < "v0.16"} "ppx_jane" {>= "v0.15" & < "v0.16"} "dune" {>= "2.0.0"} ] synopsis: "String type based on [Bigarray], for use in I/O and C-bindings" description: " String type based on [Bigarray], for use in I/O and C-bindings. " base_bigstring-0.15.0/dune-project000066400000000000000000000000201420273305200170670ustar00rootroot00000000000000(lang dune 1.10)base_bigstring-0.15.0/src/000077500000000000000000000000001420273305200153445ustar00rootroot00000000000000base_bigstring-0.15.0/src/base_bigstring.h000066400000000000000000000003451420273305200205010ustar00rootroot00000000000000#ifndef __BASE_BIGSTRING_H #define __BASE_BIGSTRING_H #include /* Bigarray flags for creating a [Bigstring.t] */ #define BASE_BIGSTRING_FLAGS (CAML_BA_CHAR | CAML_BA_C_LAYOUT) #endif /* __BASE_BIGSTRING_H */ base_bigstring-0.15.0/src/base_bigstring.ml000066400000000000000000000576311420273305200206740ustar00rootroot00000000000000open! Base module Bigstring0 = struct type t = ( char , Stdlib.Bigarray.int8_unsigned_elt , Stdlib.Bigarray.c_layout ) Stdlib.Bigarray.Array1.t end module Array1 = struct type ('a, 'b, 'c) t = ('a, 'b, 'c) Stdlib.Bigarray.Array1.t external get : ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_ref_1" external set : ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_set_1" external unsafe_get : ('a, 'b, 'c) t -> int -> 'a = "%caml_ba_unsafe_ref_1" external unsafe_set : ('a, 'b, 'c) t -> int -> 'a -> unit = "%caml_ba_unsafe_set_1" external dim : ('a, 'b, 'c) t -> int = "%caml_ba_dim_1" end include Bigstring0 external aux_create : max_mem_waiting_gc_in_bytes:int -> size:int -> t = "bigstring_alloc" let sprintf = Printf.sprintf (* One needs to use [Caml.Sys.word_size] so that its value is known at compile-time. *) let arch_sixtyfour = Caml.Sys.word_size = 64 let arch_big_endian = Caml.Sys.big_endian let not_on_32bit = Caml.Sys.word_size > 32 let create ?max_mem_waiting_gc_in_bytes size = let max_mem_waiting_gc_in_bytes = Option.value max_mem_waiting_gc_in_bytes ~default:(-1) in (* This check is important because [aux_create ~size:(-1)] raises [Out_of_memory], which could be confusing during debugging. *) if size < 0 then invalid_arg (sprintf "create: size = %d < 0" size); aux_create ~max_mem_waiting_gc_in_bytes ~size ;; 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 (* Be careful with overflow! We could have bogons like [pos = Int.max_value] or [len = Int.max_value] passed by the user. *) 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 ;; (* Blitting *) external unsafe_blit : src:t -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit = "bigstring_blit_stub" [@@noalloc] (* 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 let create ~len = create len let length = length end module Bytes_sequence = struct type t = bytes let create ~len = Bytes.create len let length = Bytes.length end include Blit.Make (struct include Bigstring_sequence let unsafe_blit = unsafe_blit end) module From_bytes = Blit.Make_distinct (Bytes_sequence) (struct external unsafe_blit : src:bytes -> src_pos:int -> dst:t -> dst_pos:int -> len:int -> unit = "bigstring_blit_bytes_bigstring_stub" [@@noalloc] include Bigstring_sequence end) module To_bytes = Blit.Make_distinct (Bigstring_sequence) (struct external unsafe_blit : src:t -> src_pos:int -> dst:bytes -> dst_pos:int -> len:int -> unit = "bigstring_blit_bigstring_bytes_stub" [@@noalloc] include Bytes_sequence end) module From_string = Blit.Make_distinct (struct type t = string let length = String.length end) (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 = struct include To_bytes include Blit.Make_to_string (Bigstring0) (To_bytes) end let of_string = From_string.subo let of_bytes = From_bytes.subo let to_string = To_string.subo let to_bytes = To_bytes.subo let sexp_of_t t = Sexp.Atom (to_string t) let t_of_sexp : Sexp.t -> t = function | Atom str -> of_string str | List _ as sexp -> Sexplib0.Sexp_conv.of_sexp_error "bigstring_of_sexp: atom needed" sexp ;; let copy t : t = sub t ~pos:0 ~len:(length t) let concat = let append ~src ~dst ~dst_pos_ref = let len = length src in let src_pos = 0 in let dst_pos = !dst_pos_ref in blit ~dst ~dst_pos ~src ~src_pos ~len; dst_pos_ref := dst_pos + len in fun ?sep list -> match list with | [] -> create 0 | head :: tail -> let head_len = length head in let sep_len = Option.value_map sep ~f:length ~default:0 in let tail_count = List.length tail in let len = head_len + (sep_len * tail_count) + List.sum (module Int) tail ~f:length in let dst = create len in let dst_pos_ref = ref 0 in append ~src:head ~dst ~dst_pos_ref; List.iter tail ~f:(fun src -> (match sep with | None -> () | Some sep -> append ~src:sep ~dst ~dst_pos_ref); append ~src ~dst ~dst_pos_ref); assert (!dst_pos_ref = len); dst ;; external unsafe_memset : t -> pos:int -> len:int -> char -> unit = "bigstring_memset_stub" [@@noalloc] let memset t ~pos ~len c = Ordered_collection_common.check_pos_len_exn ~pos ~len ~total_length:(length t); unsafe_memset t ~pos ~len c ;; (* Comparison *) external unsafe_memcmp : t -> pos1:int -> t -> pos2:int -> len:int -> int = "bigstring_memcmp_stub" [@@noalloc] let memcmp t1 ~pos1 t2 ~pos2 ~len = Ordered_collection_common.check_pos_len_exn ~pos:pos1 ~len ~total_length:(length t1); Ordered_collection_common.check_pos_len_exn ~pos:pos2 ~len ~total_length:(length t2); unsafe_memcmp t1 ~pos1 t2 ~pos2 ~len ;; external unsafe_memcmp_bytes : t -> pos1:int -> Bytes.t -> pos2:int -> len:int -> int = "bigstring_memcmp_bytes_stub" [@@noalloc] let memcmp_bytes t1 ~pos1 bytes ~pos2 ~len = Ordered_collection_common.check_pos_len_exn ~pos:pos1 ~len ~total_length:(length t1); Ordered_collection_common.check_pos_len_exn ~pos:pos2 ~len ~total_length:(Bytes.length bytes); unsafe_memcmp_bytes t1 ~pos1 bytes ~pos2 ~len ;; 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 ~pos1:0 t2 ~pos2:0 ~len with | 0 -> if len1 < len2 then -1 else if len1 > len2 then 1 else 0 | n -> n) ;; external internalhash_fold_bigstring : Hash.state -> t -> Hash.state = "internalhash_fold_bigstring" [@@noalloc] let _making_sure_the_C_binding_takes_an_int (x : Hash.state) = (x :> int) let hash_fold_t = internalhash_fold_bigstring let hash = Ppx_hash_lib.Std.Hash.of_fold hash_fold_t type t_frozen = t [@@deriving compare, hash, sexp] 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 ~pos1:0 t2 ~pos2:0 ~len:len1) 0) ;; (* Search *) external unsafe_find : t -> char -> pos:int -> len:int -> int = "bigstring_find" [@@noalloc] 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 ;; (* 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 get_16 (t : t) (pos : int) : int = check_args ~loc:"get_16" ~pos ~len:2 t; unsafe_get_16 t pos ;; let get_32 (t : t) (pos : int) : int32 = check_args ~loc:"get_32" ~pos ~len:4 t; unsafe_get_32 t pos ;; let get_64 (t : t) (pos : int) : int64 = check_args ~loc:"get_64" ~pos ~len:8 t; unsafe_get_64 t pos ;; let set_16_trunc (t : t) (pos : int) (v : int) : unit = check_args ~loc:"set_16" ~pos ~len:2 t; unsafe_set_16 t pos v ;; let set_32 (t : t) (pos : int) (v : int32) : unit = check_args ~loc:"set_32" ~pos ~len:4 t; unsafe_set_32 t pos v ;; let set_64 (t : t) (pos : int) (v : int64) : unit = check_args ~loc:"set_64" ~pos ~len:8 t; unsafe_set_64 t pos v ;; let sign_extend_16 u = (u lsl (Int.num_bits - 16)) asr (Int.num_bits - 16) let check_valid_uint16 x ~loc = if x < 0 || x > 0xFFFF then invalid_arg (sprintf "%s: %d is not a valid unsigned 16-bit integer" loc x) ;; let check_valid_int16 x ~loc = if x < -0x8000 || x > 0x7FFF then invalid_arg (sprintf "%s: %d is not a valid (signed) 16-bit integer" loc x) ;; let check_valid_uint8 x ~loc = if x < 0 || x > 0xFF then invalid_arg (sprintf "%s: %d is not a valid unsigned 8-bit integer" loc x) ;; let check_valid_int8 x ~loc = if x < -0x80 || x > 0x7F then invalid_arg (sprintf "%s: %d is not a valid (signed) 8-bit integer" loc x) ;; let check_valid_int32 = if not arch_sixtyfour then fun _ ~loc:_ -> () else fun x ~loc -> if x >= -1 lsl 31 && x < 1 lsl 31 then () else invalid_arg (sprintf "%s: %d is not a valid (signed) 32-bit integer" loc x) ;; let check_valid_uint32 = if not arch_sixtyfour then fun x ~loc -> if x >= 0 then () else invalid_arg (sprintf "%s: %d is not a valid unsigned 32-bit integer" loc x) else fun x ~loc -> if x >= 0 && x < 1 lsl 32 then () else invalid_arg (sprintf "%s: %d is not a valid unsigned 32-bit integer" loc x) ;; let check_valid_uint64 x ~loc = if x >= 0 then () else invalid_arg (sprintf "%s: %d is not a valid unsigned 64-bit integer" loc x) ;; 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 read_int16 t ~pos = sign_extend_16 (get_16 t pos) let read_int16_swap t ~pos = sign_extend_16 (swap16 (get_16 t pos)) let write_int16_exn t ~pos x = check_valid_int16 x ~loc:"Bigstring.write_int16"; set_16_trunc t pos x ;; let write_int16_swap_exn t ~pos x = (* Omit "_swap" from the error message it's bi-endian. *) check_valid_int16 x ~loc:"Bigstring.write_int16"; set_16_trunc 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 read_uint16 t ~pos = get_16 t pos let read_uint16_swap t ~pos = swap16 (get_16 t pos) let write_uint16_exn t ~pos x = check_valid_uint16 x ~loc:"Bigstring.write_uint16"; set_16_trunc t pos x ;; let write_uint16_swap_exn t ~pos x = (* Omit "_swap" from the error message it's bi-endian. *) check_valid_uint16 x ~loc:"Bigstring.write_uint16"; set_16_trunc 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 read_int32_int t ~pos = int32_to_int (get_32 t pos) let read_int32_int_swap t ~pos = int32_to_int (swap32 (get_32 t pos)) let read_int32 t ~pos = get_32 t pos let read_int32_swap t ~pos = swap32 (get_32 t pos) let write_int32 t ~pos x = set_32 t pos x let write_int32_swap t ~pos x = set_32 t pos (swap32 x) let write_int32_int_exn t ~pos x = check_valid_int32 x ~loc:"Bigstring.write_int32_int"; set_32 t pos (int32_of_int x) ;; let write_int32_int_swap_exn t ~pos x = (* Omit "_swap" from the error message it's bi-endian. *) check_valid_int32 x ~loc:"Bigstring.write_int32_int"; set_32 t pos (swap32 (int32_of_int x)) ;; let[@inline always] unsafe_read_int64_int t ~pos = int64_to_int (unsafe_get_64 t pos) let[@inline always] unsafe_read_int64_int_swap t ~pos = int64_to_int (swap64 (unsafe_get_64 t pos)) ;; let[@inline always] unsafe_read_int64 t ~pos = unsafe_get_64 t pos let[@inline always] unsafe_read_int64_swap t ~pos = swap64 (unsafe_get_64 t pos) let[@inline always] unsafe_write_int64 t ~pos x = unsafe_set_64 t pos x let[@inline always] unsafe_write_int64_swap t ~pos x = unsafe_set_64 t pos (swap64 x) let[@inline always] unsafe_write_int64_int t ~pos x = unsafe_set_64 t pos (int64_of_int x) let[@inline always] unsafe_write_int64_int_swap t ~pos x = unsafe_set_64 t pos (swap64 (int64_of_int x)) ;; let[@inline always] read_int64_int t ~pos = int64_to_int (get_64 t pos) let[@inline always] read_int64_int_swap t ~pos = int64_to_int (swap64 (get_64 t pos)) let[@inline always] read_int64 t ~pos = get_64 t pos let[@inline always] read_int64_swap t ~pos = swap64 (get_64 t pos) let write_int64 t ~pos x = set_64 t pos x let write_int64_swap t ~pos x = set_64 t pos (swap64 x) let write_int64_int t ~pos x = set_64 t pos (int64_of_int x) let write_int64_int_swap t ~pos x = set_64 t pos (swap64 (int64_of_int x)) let unsafe_get_int16_be = if arch_big_endian then unsafe_read_int16 else unsafe_read_int16_swap ;; let unsafe_get_int16_le = if arch_big_endian then unsafe_read_int16_swap else unsafe_read_int16 ;; let unsafe_get_uint16_be = if arch_big_endian then unsafe_read_uint16 else unsafe_read_uint16_swap ;; let unsafe_get_uint16_le = if arch_big_endian then unsafe_read_uint16_swap else unsafe_read_uint16 ;; let get_int16_be = if arch_big_endian then read_int16 else read_int16_swap let get_int16_le = if arch_big_endian then read_int16_swap else read_int16 let get_uint16_be = if arch_big_endian then read_uint16 else read_uint16_swap let get_uint16_le = if arch_big_endian then read_uint16_swap else read_uint16 let unsafe_set_int16_be = if arch_big_endian then unsafe_write_int16 else unsafe_write_int16_swap ;; let unsafe_set_int16_le = if arch_big_endian then unsafe_write_int16_swap else unsafe_write_int16 ;; let unsafe_set_uint16_be = if arch_big_endian then unsafe_write_uint16 else unsafe_write_uint16_swap ;; let unsafe_set_uint16_le = if arch_big_endian then unsafe_write_uint16_swap else unsafe_write_uint16 ;; let set_int16_be_exn = if arch_big_endian then write_int16_exn else write_int16_swap_exn let set_int16_le_exn = if arch_big_endian then write_int16_swap_exn else write_int16_exn let set_uint16_be_exn = if arch_big_endian then write_uint16_exn else write_uint16_swap_exn ;; let set_uint16_le_exn = if arch_big_endian then write_uint16_swap_exn else write_uint16_exn ;; let unsafe_get_int32_t_be = if arch_big_endian then unsafe_read_int32 else unsafe_read_int32_swap ;; let unsafe_get_int32_t_le = if arch_big_endian then unsafe_read_int32_swap else unsafe_read_int32 ;; let unsafe_set_int32_t_be = if arch_big_endian then unsafe_write_int32 else unsafe_write_int32_swap ;; let unsafe_set_int32_t_le = if arch_big_endian then unsafe_write_int32_swap else unsafe_write_int32 ;; let get_int32_t_be = if arch_big_endian then read_int32 else read_int32_swap let get_int32_t_le = if arch_big_endian then read_int32_swap else read_int32 let set_int32_t_be = if arch_big_endian then write_int32 else write_int32_swap let set_int32_t_le = if arch_big_endian then write_int32_swap else write_int32 let unsafe_get_int32_be = if arch_big_endian then unsafe_read_int32_int else unsafe_read_int32_int_swap ;; let unsafe_get_int32_le = if arch_big_endian then unsafe_read_int32_int_swap else unsafe_read_int32_int ;; let unsafe_set_int32_be = if arch_big_endian then unsafe_write_int32_int else unsafe_write_int32_int_swap ;; let unsafe_set_int32_le = if arch_big_endian then unsafe_write_int32_int_swap else unsafe_write_int32_int ;; let get_int32_be = if arch_big_endian then read_int32_int else read_int32_int_swap let get_int32_le = if arch_big_endian then read_int32_int_swap else read_int32_int let set_int32_be_exn = if arch_big_endian then write_int32_int_exn else write_int32_int_swap_exn ;; let set_int32_le_exn = if arch_big_endian then write_int32_int_swap_exn else write_int32_int_exn ;; let unsafe_get_int64_be_trunc = if arch_big_endian then unsafe_read_int64_int else unsafe_read_int64_int_swap ;; let unsafe_get_int64_le_trunc = if arch_big_endian then unsafe_read_int64_int_swap else unsafe_read_int64_int ;; let unsafe_set_int64_be = if arch_big_endian then unsafe_write_int64_int else unsafe_write_int64_int_swap ;; let unsafe_set_int64_le = if arch_big_endian then unsafe_write_int64_int_swap else unsafe_write_int64_int ;; let get_int64_be_trunc = if arch_big_endian then read_int64_int else read_int64_int_swap let get_int64_le_trunc = if arch_big_endian then read_int64_int_swap else read_int64_int let set_int64_be = if arch_big_endian then write_int64_int else write_int64_int_swap let set_int64_le = if arch_big_endian then write_int64_int_swap else write_int64_int let unsafe_get_int64_t_be = if arch_big_endian then unsafe_read_int64 else unsafe_read_int64_swap ;; let unsafe_get_int64_t_le = if arch_big_endian then unsafe_read_int64_swap else unsafe_read_int64 ;; let unsafe_set_int64_t_be = if arch_big_endian then unsafe_write_int64 else unsafe_write_int64_swap ;; let unsafe_set_int64_t_le = if arch_big_endian then unsafe_write_int64_swap else unsafe_write_int64 ;; let get_int64_t_be = if arch_big_endian then read_int64 else read_int64_swap let get_int64_t_le = if arch_big_endian then read_int64_swap else read_int64 let set_int64_t_be = if arch_big_endian then write_int64 else write_int64_swap let set_int64_t_le = if arch_big_endian then write_int64_swap else write_int64 let int64_conv_error () = failwith "unsafe_read_int64: value cannot be represented unboxed!" ;; let uint64_conv_error () = failwith "unsafe_read_uint64: value cannot be represented unboxed!" ;; (* [Poly] is required so that we can compare unboxed [int64]. *) let[@inline always] int64_to_int_exn n = if arch_sixtyfour then if Poly.(n >= -0x4000_0000_0000_0000L && n < 0x4000_0000_0000_0000L) then int64_to_int n else int64_conv_error () else if Poly.(n >= -0x0000_0000_4000_0000L && n < 0x0000_0000_4000_0000L) then int64_to_int n else int64_conv_error () ;; let[@inline always] uint64_to_int_exn n = if arch_sixtyfour then if Poly.(n >= 0L && n < 0x4000_0000_0000_0000L) then int64_to_int n else uint64_conv_error () else if Poly.(n >= 0L && n < 0x0000_0000_4000_0000L) then int64_to_int n else uint64_conv_error () ;; let[@inline] unsafe_get_int64_be_exn t ~pos = int64_to_int_exn (unsafe_get_int64_t_be t ~pos) ;; let[@inline] unsafe_get_int64_le_exn t ~pos = int64_to_int_exn (unsafe_get_int64_t_le t ~pos) ;; let get_int64_be_exn t ~pos = int64_to_int_exn (get_int64_t_be t ~pos) let get_int64_le_exn t ~pos = int64_to_int_exn (get_int64_t_le t ~pos) let[@inline] unsafe_get_uint64_be_exn t ~pos = uint64_to_int_exn (unsafe_get_int64_t_be t ~pos) ;; let[@inline] unsafe_get_uint64_le_exn t ~pos = uint64_to_int_exn (unsafe_get_int64_t_le t ~pos) ;; let get_uint64_be_exn t ~pos = uint64_to_int_exn (get_int64_t_be t ~pos) let get_uint64_le_exn t ~pos = uint64_to_int_exn (get_int64_t_le t ~pos) let unsafe_set_uint64_be = unsafe_set_int64_be let unsafe_set_uint64_le = unsafe_set_int64_le let set_uint64_be_exn t ~pos n = check_valid_uint64 ~loc:"Bigstring.set_uint64_be_exn" n; set_int64_be t ~pos n ;; let set_uint64_le_exn t ~pos n = check_valid_uint64 ~loc:"Bigstring.set_uint64_le_exn" n; set_int64_le t ~pos n ;; (* Type annotations on the [t]s are important here: in order for the compiler to generate optimized code, it needs to know the fully instantiated type of the bigarray. This is because the type of the bigarray encodes the element kind and the layout of the bigarray. Without the annotation the compiler generates a C call to the generic access functions. *) let unsafe_set_uint8 (t : t) ~pos n = Array1.unsafe_set t pos (Char.unsafe_of_int n) let unsafe_set_int8 (t : 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 : t) ~pos = Char.to_int (Array1.unsafe_get t pos) let unsafe_get_int8 (t : t) ~pos = let n = Char.to_int (Array1.unsafe_get t pos) in if n >= 128 then n - 256 else n ;; let set_uint8_exn (t : t) ~pos n = check_valid_uint8 ~loc:"Bigstring.set_uint8_exn" n; Array1.set t pos (Char.unsafe_of_int n) ;; let set_int8_exn (t : t) ~pos n = check_valid_int8 ~loc:"Bigstring.set_int8_exn" n; let n = if n < 0 then n + 256 else n in Array1.set t pos (Char.unsafe_of_int n) ;; let get_uint8 (t : t) ~pos = Char.to_int (Array1.get t pos) let get_int8 (t : t) ~pos = let n = Char.to_int (Array1.get t pos) in if n >= 128 then n - 256 else n ;; let mask32_n = Caml.Nativeint.(sub (shift_left 1n 32) 1n) let[@inline always] uint32_of_int32_t n = if not_on_32bit then (* use Caml.Nativeint to ensure inlining even without x-library-inlining *) Caml.Nativeint.(to_int (logand (of_int32 n) mask32_n)) else int32_to_int n ;; let[@inline] unsafe_set_uint32_le t ~pos n = unsafe_set_int32_t_le t ~pos (int32_of_int n) let[@inline] unsafe_set_uint32_be t ~pos n = unsafe_set_int32_t_be t ~pos (int32_of_int n) let[@inline] unsafe_get_uint32_le t ~pos = uint32_of_int32_t (unsafe_get_int32_t_le t ~pos) ;; let[@inline] unsafe_get_uint32_be t ~pos = uint32_of_int32_t (unsafe_get_int32_t_be t ~pos) ;; let set_uint32_le_exn t ~pos n = check_valid_uint32 ~loc:"Bigstring.set_uint32_le_exn" n; let n = if not_on_32bit && n >= 1 lsl 31 then n - (1 lsl 32) else n in set_int32_le_exn t ~pos n ;; let set_uint32_be_exn t ~pos n = check_valid_uint32 ~loc:"Bigstring.set_uint32_be_exn" n; let n = if not_on_32bit && n >= 1 lsl 31 then n - (1 lsl 32) else n in set_int32_be_exn t ~pos n ;; let get_uint32_le t ~pos = uint32_of_int32_t (get_int32_t_le t ~pos) let get_uint32_be t ~pos = uint32_of_int32_t (get_int32_t_be t ~pos) module Int_repr = struct module F = struct type t = t_frozen let get_uint8 t pos = get_uint8 t ~pos let set_uint8 t pos x = Array1.set t pos (Char.unsafe_of_int x) let get_uint16_ne t pos = get_16 t pos let set_uint16_ne t pos x = set_16_trunc t pos x let get_int32_ne t pos = get_32 t pos let set_int32_ne t pos x = set_32 t pos x let get_int64_ne t pos = get_64 t pos let set_int64_ne t pos x = set_64 t pos x end include Int_repr.Make_get (F) include Int_repr.Make_set (F) module Unsafe = struct module F = struct type t = t_frozen let get_uint8 t pos = unsafe_get_uint8 t ~pos let set_uint8 t pos x = unsafe_set_uint8 t ~pos x let get_uint16_ne t pos = unsafe_get_16 t pos let set_uint16_ne t pos x = unsafe_set_16 t pos x let get_int32_ne t pos = unsafe_get_32 t pos let set_int32_ne t pos x = unsafe_set_32 t pos x let get_int64_ne t pos = unsafe_get_64 t pos let set_int64_ne t pos x = unsafe_set_64 t pos x end include Int_repr.Make_get (F) include Int_repr.Make_set (F) end end module Private = struct let sign_extend_16 = sign_extend_16 end base_bigstring-0.15.0/src/base_bigstring.mli000066400000000000000000000264111420273305200210350ustar00rootroot00000000000000(** String type based on [Bigarray], for use in I/O and C-bindings. *) open! Base open Stdlib.Bigarray (** {2 Types and exceptions} *) (** Type of bigstrings *) type t = (char, int8_unsigned_elt, c_layout) Array1.t [@@deriving compare, sexp] (** Type of bigstrings which support hashing. Note that mutation invalidates previous hashes. *) type t_frozen = t [@@deriving compare, hash, sexp] include Equal.S with type t := t (** {2 Creation and string conversion} *) (** [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_in_bytes], the pressure in the garbage collector to be more agressive will increase. @return a new bigstring having [length]. Content is undefined. *) val create : ?max_mem_waiting_gc_in_bytes:int -> int -> t (** [init n ~f] creates a bigstring [t] of length [n], with [t.{i} = f i]. *) val init : int -> f:(int -> char) -> 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 of_string : ?pos:int -> ?len:int -> string -> t (** [of_bytes ?pos ?len str] @return a new bigstring that is equivalent to the subbytes of length [len] in [str] starting at position [pos]. @param pos default = 0 @param len default = [Bytes.length str - pos] *) val of_bytes : ?pos:int -> ?len:int -> bytes -> t (** [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. *) val to_string : ?pos:int -> ?len:int -> t -> string (** [to_bytes ?pos ?len bstr] @return a new byte sequence 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 bytes would exceed runtime limits. *) val to_bytes : ?pos:int -> ?len:int -> t -> bytes (** [concat ?sep list] returns the concatenation of [list] with [sep] in between each. *) val concat : ?sep:t -> t list -> t (** {2 Checking} *) (** [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 check_args : loc:string -> pos:int -> len:int -> t -> unit (** [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. *) val get_opt_len : t -> pos:int -> int option -> int (** {2 Accessors} *) (** [length bstr] @return the length of bigstring [bstr]. *) val length : t -> int (** [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" (** [is_mmapped bstr] @return whether the bigstring [bstr] is memory-mapped. *) external is_mmapped : t -> bool = "bigstring_is_mmapped_stub" [@@noalloc] (** {2 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 val copy : t -> t module To_string : sig val blit : (t, bytes) Blit.blit [@@deprecated "[since 2017-10] use [Bigstring.To_bytes.blit] instead"] val blito : (t, bytes) Blit.blito [@@deprecated "[since 2017-10] use [Bigstring.To_bytes.blito] instead"] val unsafe_blit : (t, bytes) Blit.blit [@@deprecated "[since 2017-10] use [Bigstring.To_bytes.unsafe_blit] instead"] include Blit.S_to_string with type t := t end module From_string : Blit.S_distinct with type src := string with type dst := t module To_bytes : Blit.S_distinct with type src := t with type dst := bytes module From_bytes : Blit.S_distinct with type src := bytes with type dst := t (** [memset t ~pos ~len c] fills [t] with [c] within the range [\[pos, pos + len)]. *) val memset : t -> pos:int -> len:int -> char -> unit (** Memcmp *) (** [memcmp t1 ~pos1 t2 ~pos2 ~len] is like [compare t1 t2] except performs the comparison on the subregions of [t1] and [t2] defined by [pos1], [pos2], and [len]. *) val memcmp : t -> pos1:int -> t -> pos2:int -> len:int -> int (** [memcmp_bytes], for efficient [memcmp] between [Bigstring] and [Bytes] data. *) val memcmp_bytes : t -> pos1:int -> Bytes.t -> pos2:int -> len:int -> int (** {2 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 (** Same as [find], but does no bounds checking, and returns a negative value instead of [None] if [char] is not found. *) external unsafe_find : t -> char -> pos:int -> len:int -> int = "bigstring_find" [@@noalloc] (** {2 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 [bigstring]s. 2. The accessors rely on the implementation of [bigstring], and hence should change should 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 [jbuild] ^_^. 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_ ::= int8 | uint8 | int16 | uint16 | int32 | uint32 | int64 | uint64 ::= _le | _be | '' The [unsafe_] prefix indicates that these functions do no bounds checking and silently truncate out-of-range numeric arguments. *) val get_int8 : t -> pos:int -> int val set_int8_exn : t -> pos:int -> int -> unit val get_uint8 : t -> pos:int -> int val set_uint8_exn : t -> pos:int -> int -> unit 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 (** {2 16-bit methods} *) val get_int16_le : t -> pos:int -> int val get_int16_be : t -> pos:int -> int val set_int16_le_exn : t -> pos:int -> int -> unit val set_int16_be_exn : t -> pos:int -> int -> unit 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 get_uint16_le : t -> pos:int -> int val get_uint16_be : t -> pos:int -> int val set_uint16_le_exn : t -> pos:int -> int -> unit val set_uint16_be_exn : 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 (** {2 32-bit methods} *) val get_int32_le : t -> pos:int -> int val get_int32_be : t -> pos:int -> int val set_int32_le_exn : t -> pos:int -> int -> unit val set_int32_be_exn : t -> pos:int -> int -> unit 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 get_uint32_le : t -> pos:int -> int val get_uint32_be : t -> pos:int -> int val set_uint32_le_exn : t -> pos:int -> int -> unit val set_uint32_be_exn : 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). *) (** {2 64-bit signed values} *) val get_int64_le_exn : t -> pos:int -> int val get_int64_be_exn : t -> pos:int -> int val get_int64_le_trunc : t -> pos:int -> int val get_int64_be_trunc : t -> pos:int -> int val set_int64_le : t -> pos:int -> int -> unit val set_int64_be : t -> pos:int -> int -> unit val unsafe_get_int64_le_exn : t -> pos:int -> int val unsafe_get_int64_be_exn : t -> pos:int -> int val unsafe_get_int64_le_trunc : t -> pos:int -> int val unsafe_get_int64_be_trunc : t -> pos:int -> int val unsafe_set_int64_le : t -> pos:int -> int -> unit val unsafe_set_int64_be : t -> pos:int -> int -> unit (** {2 64-bit unsigned values} *) val get_uint64_be_exn : t -> pos:int -> int val get_uint64_le_exn : t -> pos:int -> int val set_uint64_le_exn : t -> pos:int -> int -> unit val set_uint64_be_exn : t -> pos:int -> int -> unit val unsafe_get_uint64_be_exn : t -> pos:int -> int val unsafe_get_uint64_le_exn : t -> pos:int -> int val unsafe_set_uint64_le : t -> pos:int -> int -> unit val unsafe_set_uint64_be : t -> pos:int -> int -> unit (** {2 32-bit methods with full precision} *) val get_int32_t_le : t -> pos:int -> Int32.t val get_int32_t_be : t -> pos:int -> Int32.t val set_int32_t_le : t -> pos:int -> Int32.t -> unit val set_int32_t_be : t -> pos:int -> Int32.t -> unit 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 (** {2 64-bit methods with full precision} *) val get_int64_t_le : t -> pos:int -> Int64.t val get_int64_t_be : t -> pos:int -> Int64.t val set_int64_t_le : t -> pos:int -> Int64.t -> unit val set_int64_t_be : t -> pos:int -> Int64.t -> unit 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 module Int_repr : sig include Int_repr.Get with type t := t include Int_repr.Set with type t := t module Unsafe : sig include Int_repr.Get with type t := t include Int_repr.Set with type t := t end end (*_ See the Jane Street Style Guide for an explanation of [Private] submodules: https://opensource.janestreet.com/standards/#private-submodules *) module Private : sig val sign_extend_16 : int -> int end base_bigstring-0.15.0/src/base_bigstring_stubs.c000066400000000000000000000131761420273305200217220ustar00rootroot00000000000000#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 #elif __CYGWIN__ #include #else #include #if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__) #include #else #include #endif #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 "base_bigstring.h" #include "internalhash.h" /* Bytes_val is only available from 4.06 */ #ifndef Bytes_val #define Bytes_val String_val #endif 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 = BASE_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) { const 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_bytes_bigstring_stub( value v_str, value v_src_pos, value v_bstr, value v_dst_pos, value v_len) { unsigned char *str = Bytes_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_bytes_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); unsigned char *str = Bytes_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); memmove(dst, src, len); return Val_unit; } CAMLprim value bigstring_memset_stub(value v_t, value v_pos, value v_len, value v_char) { struct caml_ba_array *ba_t = Caml_ba_array_val(v_t); char *buffer = ((char *) ba_t->data) + Long_val(v_pos); memset(buffer, Int_val(v_char), Long_val(v_len)); return Val_unit; } /* Comparison */ static inline value caml_memcmp(unsigned char * s1, unsigned char * s2, size_t n) { int res = memcmp(s1, s2, n); if (res < 0) return Val_int(-1); if (res > 0) return Val_int(1); return Val_int(0); } 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); return caml_memcmp((unsigned char *) ba_s1->data + Long_val(v_s1_pos), (unsigned char *) ba_s2->data + Long_val(v_s2_pos), Long_val(v_len)); } CAMLprim value bigstring_memcmp_bytes_stub(value v_bstr, value v_s1_pos, value v_bytes, value v_s2_pos, value v_len) /* noalloc */ { struct caml_ba_array *ba_s1 = Caml_ba_array_val(v_bstr); return caml_memcmp((unsigned char *) ba_s1->data + Long_val(v_s1_pos), Bytes_val(v_bytes) + Long_val(v_s2_pos), Long_val(v_len)); } /* Hashing */ CAMLprim value internalhash_fold_bigstring(value st, value v_str) /* noalloc */ { uint32_t h = Long_val(st); struct caml_ba_array *ba = Caml_ba_array_val(v_str); uint8_t *s = (uint8_t *) ba->data; mlsize_t len = ba->dim[0]; h = Base_internalhash_fold_blob(h, len, s); return Val_long(h); } /* Search */ CAMLprim value bigstring_find(value v_str, value v_needle, value v_pos, value v_len) { char *start, *r; intnat 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); } base_bigstring-0.15.0/src/dune000066400000000000000000000002771420273305200162300ustar00rootroot00000000000000(library (name base_bigstring) (public_name base_bigstring) (js_of_ocaml (javascript_files runtime.js)) (libraries base int_repr) (c_names base_bigstring_stubs) (preprocess (pps ppx_jane)))base_bigstring-0.15.0/src/runtime.js000066400000000000000000000045621420273305200173740ustar00rootroot00000000000000///////// BIGSTRING //Provides: bigstring_alloc //Requires: caml_ba_create function bigstring_alloc(_,size){ return caml_ba_create(12, 0, [0,size]); } //Provides: bigstring_is_mmapped_stub function bigstring_is_mmapped_stub(x){ return 0; } //Provides: bigstring_blit_stub //Requires: caml_bigstring_blit_ba_to_ba function bigstring_blit_stub(s1, i1, s2, i2, len){ return caml_bigstring_blit_ba_to_ba(s1,i1,s2,i2,len); } //Provides: bigstring_blit_bytes_bigstring_stub //Requires: caml_bigstring_blit_bytes_to_ba function bigstring_blit_bytes_bigstring_stub(src, src_pos, dst, dst_pos, len){ return caml_bigstring_blit_bytes_to_ba(src,src_pos,dst,dst_pos,len); } //Provides: bigstring_blit_bigstring_bytes_stub //Requires: caml_bigstring_blit_ba_to_bytes function bigstring_blit_bigstring_bytes_stub(src, src_pos, dst, dst_pos, len){ return caml_bigstring_blit_ba_to_bytes(src,src_pos,dst,dst_pos,len); } //Provides: bigstring_blit_string_bigstring_stub //Requires: caml_bigstring_blit_string_to_ba function bigstring_blit_string_bigstring_stub(src, src_pos, dst, dst_pos, len){ return caml_bigstring_blit_string_to_ba(src,src_pos,dst,dst_pos,len); } //Provides: bigstring_memset_stub //Requires: caml_ba_set_1 function bigstring_memset_stub(bigstring, v_pos, v_len, v_char) { for (var i = 0; i < v_len; i++) { caml_ba_set_1(bigstring, v_pos + i, v_char); } } //Provides: bigstring_memcmp_stub //Requires: caml_ba_get_1 function bigstring_memcmp_stub(v_s1, v_s1_pos, v_s2, v_s2_pos, v_len){ for (var i = 0; i < v_len; i++) { var a = caml_ba_get_1(v_s1,v_s1_pos + i); var b = caml_ba_get_1(v_s2,v_s2_pos + i); if (a < b) return -1; if (a > b) return 1; } return 0; } //Provides: bigstring_memcmp_bytes_stub //Requires: caml_ba_get_1, caml_bytes_get function bigstring_memcmp_bytes_stub(v_s1, v_s1_pos, v_s2, v_s2_pos, v_len) { for (var i = 0; i < v_len; i++) { var a = caml_ba_get_1(v_s1, v_s1_pos + i); var b = caml_bytes_get(v_s2, v_s2_pos + i); if (a < b) return -1; if (a > b) return 1; } return 0; } //Provides: internalhash_fold_bigstring //Requires: caml_hash_mix_bigstring var internalhash_fold_bigstring = caml_hash_mix_bigstring //Provides: bigstring_find //Requires: caml_ba_get_1 function bigstring_find(bs, chr, pos, len){ while(len > 0){ if(caml_ba_get_1(bs,pos) == chr) return pos; pos++; len--; } return -1; } base_bigstring-0.15.0/test/000077500000000000000000000000001420273305200155345ustar00rootroot00000000000000base_bigstring-0.15.0/test/dune000066400000000000000000000001661420273305200164150ustar00rootroot00000000000000(library (name base_bigstring_test) (libraries base_bigstring expect_test_helpers_core) (preprocess (pps ppx_jane)))base_bigstring-0.15.0/test/import.ml000066400000000000000000000007361420273305200174060ustar00rootroot00000000000000include Base include Stdio include Base_for_tests include Expect_test_helpers_core module Quickcheck = struct include Core.Quickcheck module Bool = Core.Bool module Char = Core.Char module Int = Core.Int module Int32 = Core.Int32 module Int64 = Core.Int64 module List = Core.List module Nativeint = Core.Nativeint module String = Core.String end module Core_kernel = struct end [@@deprecated "[since 1970-01] Don't use Core_kernel in Base tests. Use Base."] base_bigstring-0.15.0/test/test_bigstring.ml000066400000000000000000000470371420273305200211300ustar00rootroot00000000000000open! Import open Base_bigstring let length = length let create = create module Bigstring_sequence = struct type nonrec t = t let create ~len = create len let get = get let set = set let length = length end module Bytes_sequence = struct type t = bytes [@@deriving sexp_of] let create ~len = Bytes.create len let get = Bytes.get let set = Bytes.set let length = Bytes.length end module Blit_elt = struct include Char let of_bool b = if b then 'a' else 'b' end module Blit_s : Blit.S with type t := t = Base_bigstring include Blit_s include Base_for_tests.Test_blit.Test (Blit_elt) (Bigstring_sequence) (Blit_s) module From_bytes = From_bytes include Base_for_tests.Test_blit.Test_distinct (Blit_elt) (Bytes_sequence) (Bigstring_sequence) (From_bytes) module To_bytes = To_bytes include Base_for_tests.Test_blit.Test_distinct (Blit_elt) (Bigstring_sequence) (Bytes_sequence) (To_bytes) module From_string = From_string module To_string = To_string let copy = copy let%test_unit "copy" = let equal a b = String.equal (to_string a) (to_string b) in let a = create 1 in set a 0 'a'; let b = copy a in assert (equal a b); set b 0 'b'; assert (not (equal a b)) ;; (* The above are produced by simple [Blit] functor applications, so just smoke-test the [unsafe_blit] functions we pass to the functors. *) let%expect_test "basic unsafe_blits" = let test unsafe_blit src_of_string dst_of_string sexp_of_dst = let dst = dst_of_string "DEFGHIJK" in unsafe_blit ~src:(src_of_string "bcdefghi") ~src_pos:1 ~dst ~dst_pos:2 ~len:3; print_s [%sexp (dst : dst)]; [%expect {| DEcdeIJK |}] in test From_string.unsafe_blit Fn.id of_string sexp_of_t ;; let to_bytes = to_bytes let to_string = to_string let sexp_of_t = sexp_of_t let of_string = of_string let of_bytes = of_bytes let t_of_sexp = t_of_sexp let%test_unit "roundtrip" = let string_gen = let open Quickcheck.Generator.Let_syntax in let%bind length = Quickcheck.Generator.small_non_negative_int in Quickcheck.Generator.list_with_length length Quickcheck.Generator.char_print >>| String.of_char_list in Quickcheck.test string_gen ~f:(fun str -> let bstr = of_string str in [%test_eq: t] bstr (of_string (to_string bstr)); [%test_eq: t] bstr (of_bytes (to_bytes bstr)); [%test_eq: t] bstr (t_of_sexp (sexp_of_t bstr))) ;; external is_mmapped : t_frozen -> bool = "bigstring_is_mmapped_stub" [@@noalloc] let%test "bigstring created with create are not mmapped" = not (is_mmapped (create 2)) let init = init let try_setters z = List.map ~f:(fun setter -> let t = init 8 ~f:(fun _ -> '\000') in Or_error.try_with (fun () -> setter t ~pos:0 z; to_string t |> String.to_list |> List.map ~f:Char.to_int)) ;; let set_int8_exn = set_int8_exn let set_uint8_exn = set_uint8_exn let set_int16_le_exn = set_int16_le_exn let set_int16_be_exn = set_int16_be_exn let set_uint16_le_exn = set_uint16_le_exn let set_uint16_be_exn = set_uint16_be_exn let set_int32_le_exn = set_int32_le_exn let set_int32_be_exn = set_int32_be_exn let set_uint32_le_exn = set_uint32_le_exn let set_uint32_be_exn = set_uint32_be_exn let set_uint64_le_exn = set_uint64_le_exn let set_uint64_be_exn = set_uint64_be_exn let%expect_test "checking setters (should end in [_exn])" = let test setters z = try_setters z setters |> List.iteri ~f:(fun i -> function | Ok bytes -> raise_s [%message "didn't raise" (z : Int.Hex.t) (i : int) (bytes : int list)] | Error _ -> ()) in test [ set_int8_exn ] 0x80; test [ set_uint8_exn ] (-1); test [ set_int16_le_exn; set_int16_be_exn ] 0x8000; test [ set_uint16_le_exn; set_uint16_be_exn ] (-1); Option.iter (Int64.to_int 0x8000_0000L) ~f:(fun z -> test [ set_int32_le_exn; set_int32_be_exn ] z); test [ set_uint32_le_exn; set_uint32_be_exn ] (-1); test [ set_uint64_le_exn; set_uint64_be_exn ] (-1) ;; let unsafe_set_int8 = unsafe_set_int8 let unsafe_set_uint8 = unsafe_set_uint8 let unsafe_set_int16_le = unsafe_set_int16_le let unsafe_set_int16_be = unsafe_set_int16_be let unsafe_set_uint16_le = unsafe_set_uint16_le let unsafe_set_uint16_be = unsafe_set_uint16_be let unsafe_set_uint32_le = unsafe_set_uint32_le let unsafe_set_uint32_be = unsafe_set_uint32_be let unsafe_set_uint64_le = unsafe_set_uint64_le let unsafe_set_uint64_be = unsafe_set_uint64_be let unsafe_set_int32_le = unsafe_set_int32_le let unsafe_set_int32_be = unsafe_set_int32_be let%test_module "truncating setters (should end in [_trunc] or begin with [unsafe_])" = (module struct let test setters z = try_setters z setters |> List.iter ~f:(fun t -> Or_error.ok_exn t |> List.iter ~f:(printf "%x "); printf "; ") ;; let%expect_test "all word sizes" = test [ unsafe_set_int8 ] 0x9080; [%expect {| 80 0 0 0 0 0 0 0 ; |}]; test [ unsafe_set_uint8 ] (-1); [%expect {| ff 0 0 0 0 0 0 0 ; |}]; test [ unsafe_set_int16_le; unsafe_set_int16_be ] 0x90_8070; [%expect {| 70 80 0 0 0 0 0 0 ; 80 70 0 0 0 0 0 0 ; |}]; test [ unsafe_set_uint16_le; unsafe_set_uint16_be ] (-1); [%expect {| ff ff 0 0 0 0 0 0 ; ff ff 0 0 0 0 0 0 ; |}]; test [ unsafe_set_uint32_le; unsafe_set_uint32_be ] (-1); [%expect {| ff ff ff ff 0 0 0 0 ; ff ff ff ff 0 0 0 0 ; |}]; test [ unsafe_set_uint64_le; unsafe_set_uint64_be ] (-1); [%expect {| ff ff ff ff ff ff ff ff ; ff ff ff ff ff ff ff ff ; |}] ;; let%expect_test (_ [@tags "64-bits-only"]) = Option.iter (Int64.to_int 0x90_8070_6050L) ~f:(fun z -> test [ unsafe_set_int32_le; unsafe_set_int32_be ] z); [%expect {| 50 60 70 80 0 0 0 0 ; 80 70 60 50 0 0 0 0 ; |}] ;; end) ;; let getter_t ~first_byte = init 8 ~f:(fun i -> i + first_byte |> Char.of_int_exn) let get_int64_le_trunc = get_int64_le_trunc let get_int64_be_trunc = get_int64_be_trunc let unsafe_get_int64_le_trunc = unsafe_get_int64_le_trunc let unsafe_get_int64_be_trunc = unsafe_get_int64_be_trunc let%test_module "truncating getters (should end in [_trunc] or begin with [unsafe_])" = (module struct let test getter = List.iter [ 0x81 (* positive if top bit truncated *) ; 0xc1 (* negative if top bit truncated *) ] ~f:(fun first_byte -> let i = getter (getter_t ~first_byte) ~pos:0 in (* Signed hex is not clear; make sure the hex is unsigned. Include the signed decimal form mainly to indicate the sign. *) printf !"0x%x (= %d)\n" i i) ;; let%expect_test ("63-bit int" [@tags "64-bits-only"]) = test get_int64_le_trunc; [%expect {| 0x887868584838281 (= 614607782171345537) 0x48c7c6c5c4c3c2c1 (= -3978993193046523199) |}]; test get_int64_be_trunc; [%expect {| 0x182838485868788 (= 108793946209421192) 0x41c2c3c4c5c6c7c8 (= -4484807029008447544) |}]; test unsafe_get_int64_le_trunc; [%expect {| 0x887868584838281 (= 614607782171345537) 0x48c7c6c5c4c3c2c1 (= -3978993193046523199) |}]; test unsafe_get_int64_be_trunc; [%expect {| 0x182838485868788 (= 108793946209421192) 0x41c2c3c4c5c6c7c8 (= -4484807029008447544) |}] ;; let%expect_test ("31-bit int" [@tags "32-bits-only", "no-js"]) = test get_int64_le_trunc; [%expect {| 0x4838281 (= 75727489) 0x44c3c2c1 (= -993803583) |}]; test get_int64_be_trunc; [%expect {| 0x5868788 (= 92702600) 0x45c6c7c8 (= -976828472) |}]; test unsafe_get_int64_le_trunc; [%expect {| 0x4838281 (= 75727489) 0x44c3c2c1 (= -993803583) |}]; test unsafe_get_int64_be_trunc; [%expect {| 0x5868788 (= 92702600) 0x45c6c7c8 (= -976828472) |}] ;; let%expect_test ("32-bit int" [@tags "js-only"]) = test get_int64_le_trunc; [%expect {| 0x84838281 (= -2071756159) 0xc4c3c2c1 (= -993803583) |}]; test get_int64_be_trunc; [%expect {| 0x85868788 (= -2054781048) 0xc5c6c7c8 (= -976828472) |}]; test unsafe_get_int64_le_trunc; [%expect {| 0x84838281 (= -2071756159) 0xc4c3c2c1 (= -993803583) |}]; test unsafe_get_int64_be_trunc; [%expect {| 0x85868788 (= -2054781048) 0xc5c6c7c8 (= -976828472) |}] ;; end) ;; let get_int64_le_exn = get_int64_le_exn let get_int64_be_exn = get_int64_be_exn let unsafe_get_int64_le_exn = unsafe_get_int64_le_exn let unsafe_get_int64_be_exn = unsafe_get_int64_be_exn let get_uint64_le_exn = get_uint64_le_exn let get_uint64_be_exn = get_uint64_be_exn let unsafe_get_uint64_le_exn = unsafe_get_uint64_le_exn let unsafe_get_uint64_be_exn = unsafe_get_uint64_be_exn let try_getters ~first_bigstring_byte = List.map ~f:(fun getter -> let t = getter_t ~first_byte:first_bigstring_byte in Or_error.try_with (fun () -> getter t ~pos:0)) ;; let%expect_test "checking getters (should end in [_exn])" = let test getters ~first_bigstring_byte = try_getters getters ~first_bigstring_byte |> List.iteri ~f:(fun i -> function | Ok z -> raise_s [%message "didn't raise" (i : int) (z : Int.Hex.t)] | Error _ -> ()) in test (* These should check that the 64th bit in the string representation is redundant, so the value is representable as a 63-bit [int] result. *) [ get_int64_le_exn ; get_int64_be_exn ; unsafe_get_int64_le_exn ; unsafe_get_int64_be_exn ; get_uint64_le_exn ; get_uint64_be_exn ; unsafe_get_uint64_le_exn ; unsafe_get_uint64_be_exn ] ~first_bigstring_byte:0x80; test (* These should additionally check that the represented integer is not negative. *) [ get_uint64_le_exn ; get_uint64_be_exn ; unsafe_get_uint64_le_exn ; unsafe_get_uint64_be_exn ] ~first_bigstring_byte:0xc0 ;; module Private = struct open Private let sign_extend_16 = sign_extend_16 let%expect_test "sign_extend_16" = List.iter [ 32768; 32767; -32768; -32769 ] ~f:(fun i -> sign_extend_16 i |> printf "%d "); [%expect {| -32768 32767 -32768 32767 |}] ;; end let unsafe_set_int64_t_be = unsafe_set_int64_t_be let unsafe_set_int64_t_le = unsafe_set_int64_t_le let set_int64_t_be = set_int64_t_be let set_int64_t_le = set_int64_t_le let%expect_test "basic int64 setters" = try_setters 0x0102030405060708L [ unsafe_set_int64_t_be; unsafe_set_int64_t_le; set_int64_t_be; set_int64_t_le ] |> printf !"%{sexp#hum:int list Or_error.t list}\n"; [%expect {| ((Ok (1 2 3 4 5 6 7 8)) (Ok (8 7 6 5 4 3 2 1)) (Ok (1 2 3 4 5 6 7 8)) (Ok (8 7 6 5 4 3 2 1))) |}] ;; let unsafe_get_int64_t_be = unsafe_get_int64_t_be let unsafe_get_int64_t_le = unsafe_get_int64_t_le let get_int64_t_be = get_int64_t_be let get_int64_t_le = get_int64_t_le let%expect_test "basic int64 getters" = try_getters ~first_bigstring_byte:1 [ unsafe_get_int64_t_be; unsafe_get_int64_t_le; get_int64_t_be; get_int64_t_le ] |> printf !"%{sexp#hum:Int64.Hex.t Or_error.t list}\n"; [%expect {| ((Ok 0x102030405060708) (Ok 0x807060504030201) (Ok 0x102030405060708) (Ok 0x807060504030201)) |}] ;; let unsafe_set_int32_t_be = unsafe_set_int32_t_be let unsafe_set_int32_t_le = unsafe_set_int32_t_le let set_int32_t_be = set_int32_t_be let set_int32_t_le = set_int32_t_le let%expect_test "basic int32 setters" = try_setters 0x01020304l [ unsafe_set_int32_t_be; unsafe_set_int32_t_le; set_int32_t_be; set_int32_t_le ] |> printf !"%{sexp#hum:int list Or_error.t list}\n"; [%expect {| ((Ok (1 2 3 4 0 0 0 0)) (Ok (4 3 2 1 0 0 0 0)) (Ok (1 2 3 4 0 0 0 0)) (Ok (4 3 2 1 0 0 0 0))) |}] ;; let unsafe_get_int32_t_be = unsafe_get_int32_t_be let unsafe_get_int32_t_le = unsafe_get_int32_t_le let get_int32_t_be = get_int32_t_be let get_int32_t_le = get_int32_t_le let%expect_test "basic int32 getters" = try_getters ~first_bigstring_byte:1 [ unsafe_get_int32_t_be; unsafe_get_int32_t_le; get_int32_t_be; get_int32_t_le ] |> printf !"%{sexp#hum:Int32.Hex.t Or_error.t list}\n"; [%expect {| ((Ok 0x1020304) (Ok 0x4030201) (Ok 0x1020304) (Ok 0x4030201)) |}] ;; let unsafe_set_int64_be = unsafe_set_int64_be let unsafe_set_int64_le = unsafe_set_int64_le let set_int64_be = set_int64_be let set_int64_le = set_int64_le let%expect_test "basic int setters" = try_setters 0x01020304 [ unsafe_set_int64_be; unsafe_set_int64_le; set_int64_be; set_int64_le ] |> printf !"%{sexp#hum:int list Or_error.t list}\n"; [%expect {| ((Ok (0 0 0 0 1 2 3 4)) (Ok (4 3 2 1 0 0 0 0)) (Ok (0 0 0 0 1 2 3 4)) (Ok (4 3 2 1 0 0 0 0))) |}] ;; let unsafe_get_uint32_be = unsafe_get_uint32_be let unsafe_get_uint32_le = unsafe_get_uint32_le let get_uint32_be = get_uint32_be let get_uint32_le = get_uint32_le let unsafe_get_int32_be = unsafe_get_int32_be let unsafe_get_int32_le = unsafe_get_int32_le let get_int32_be = get_int32_be let get_int32_le = get_int32_le let unsafe_get_uint16_be = unsafe_get_uint16_be let unsafe_get_uint16_le = unsafe_get_uint16_le let get_uint16_be = get_uint16_be let get_uint16_le = get_uint16_le let unsafe_get_int16_be = unsafe_get_int16_be let unsafe_get_int16_le = unsafe_get_int16_le let get_int16_be = get_int16_be let get_int16_le = get_int16_le let unsafe_get_uint8 = unsafe_get_uint8 let unsafe_get_int8 = unsafe_get_int8 let get_uint8 = get_uint8 let get_int8 = get_int8 let%expect_test "basic int getters" = try_getters ~first_bigstring_byte:1 [ unsafe_get_uint32_be ; unsafe_get_uint32_le ; get_uint32_be ; get_uint32_le ; unsafe_get_int32_be ; unsafe_get_int32_le ; get_int32_be ; get_int32_le ; unsafe_get_uint16_be ; unsafe_get_uint16_le ; get_uint16_be ; get_uint16_le ; unsafe_get_int16_be ; unsafe_get_int16_le ; get_int16_be ; get_int16_le ; unsafe_get_uint8 ; unsafe_get_int8 ; get_uint8 ; get_int8 ] |> printf !"%{sexp#hum:Int.Hex.t Or_error.t list}\n"; [%expect {| ((Ok 0x1020304) (Ok 0x4030201) (Ok 0x1020304) (Ok 0x4030201) (Ok 0x1020304) (Ok 0x4030201) (Ok 0x1020304) (Ok 0x4030201) (Ok 0x102) (Ok 0x201) (Ok 0x102) (Ok 0x201) (Ok 0x102) (Ok 0x201) (Ok 0x102) (Ok 0x201) (Ok 0x1) (Ok 0x1) (Ok 0x1) (Ok 0x1)) |}] ;; external unsafe_find : t_frozen -> char -> pos:int -> len:int -> int = "bigstring_find" [@@noalloc] let%expect_test "basic unsafe_find" = let t = of_string "abc" in [%test_result: int] ~expect:1 (unsafe_find t 'b' ~pos:1 ~len:1); [%test_result: int] ~expect:1 (unsafe_find t 'b' ~pos:1 ~len:2); [%test_pred: int] Int.is_negative (unsafe_find t 'd' ~pos:1 ~len:2) ;; let find = find let%expect_test "basic find" = let t = of_string "abc" in [%test_result: int option] ~expect:(Some 1) (find 'b' t ~pos:1 ~len:1); [%test_result: int option] ~expect:None (find 'b' t ~pos:1 ~len:0); require_does_raise [%here] (fun () -> find 'b' t ~len:4); [%expect {| (Invalid_argument "Bigstring.find: length(bstr) < pos + len") |}]; require_does_raise [%here] (fun () -> find 'd' t ~len:4); [%expect {| (Invalid_argument "Bigstring.find: length(bstr) < pos + len") |}]; [%test_result: int option] ~expect:(Some 1) (find 'b' t ~pos:1 ~len:2); [%test_result: int option] ~expect:None (find 'd' t ~pos:1 ~len:2); [%test_result: int option] ~expect:None (find 'b' t ~len:1); [%test_result: int option] ~expect:(Some 1) (find 'b' t ~pos:1); [%test_result: int option] ~expect:None (find 'd' t); require_does_raise [%here] (fun () -> find 'b' t ~pos:4); [%expect {| (Invalid_argument "find: len < 0") |}] ;; let get_opt_len = get_opt_len let%expect_test "basic get_opt_len" = let t = of_string "abc" in [%test_result: int] ~expect:2 (get_opt_len t ~pos:1 None); [%test_result: int] ~expect:5 (get_opt_len t ~pos:1 (Some 5)); [%test_result: int] ~expect:1 (get_opt_len t ~pos:1 (Some 1)); [%test_result: int] ~expect:0 (get_opt_len t ~pos:1 (Some 0)) ;; let memcmp = memcmp let memcmp_bytes = memcmp_bytes let%test_module "basic memcmp" = (module struct let s1 = "221007247563588720" let s2 = "1650905272620466461" let test_memcmp ~memcmp t1 t2 = [%test_result: int] ~expect:0 (memcmp t1 ~pos1:0 t2 ~pos2:0 ~len:0); [%test_pred: int] Int.is_positive (memcmp t1 ~pos1:0 t2 ~pos2:0 ~len:3); [%test_pred: int] Int.is_negative (memcmp t1 ~pos1:0 t2 ~pos2:1 ~len:3) ;; let%expect_test "bigstring to bigstring" = test_memcmp ~memcmp (of_string s1) (of_string s2) ;; let%expect_test "bigstring to bytes" = test_memcmp ~memcmp:memcmp_bytes (of_string s1) (Bytes.of_string s2) ;; end) ;; let memset = memset external set : t_frozen -> int -> char -> unit = "%caml_ba_set_1" let%expect_test "basic char setters" = try_setters 'x' [ memset ~len:0; memset ~len:1; memset ~len:2; (fun t ~pos -> set t pos) ] |> printf !"%{sexp#hum:int list Or_error.t list}\n"; [%expect {| ((Ok (0 0 0 0 0 0 0 0)) (Ok (120 0 0 0 0 0 0 0)) (Ok (120 120 0 0 0 0 0 0)) (Ok (120 0 0 0 0 0 0 0))) |}] ;; external get : t_frozen -> int -> char = "%caml_ba_ref_1" let%expect_test "basic char getters" = try_getters ~first_bigstring_byte:1 [ (fun t ~pos -> get t pos) ] |> printf !"%{sexp#hum:char Or_error.t list}\n"; [%expect {| ((Ok "\001")) |}] ;; let check_args = check_args let%expect_test "basic check_args" = require_does_raise [%here] (fun () -> check_args ~loc:"LOC" ~pos:Int.max_value ~len:2 (of_string "abc")); [%expect {| (Invalid_argument "Bigstring.LOC: length(bstr) < pos + len") |}]; check_args ~loc:"LOC" ~pos:0 ~len:0 (of_string ""); require_does_raise [%here] (fun () -> check_args ~loc:"LOC" ~pos:1 ~len:0 (of_string "")); [%expect {| (Invalid_argument "Bigstring.LOC: length(bstr) < pos + len") |}]; require_does_raise [%here] (fun () -> check_args ~loc:"LOC" ~pos:0 ~len:1 (of_string "")); [%expect {| (Invalid_argument "Bigstring.LOC: length(bstr) < pos + len") |}]; check_args ~loc:"LOC" ~pos:0 ~len:0 (of_string "STRING") ;; let concat = concat let%expect_test "basic concat" = List.iter [ None; Some (of_string "; ") ] ~f:(fun sep -> List.iter [ []; [ "fst1" ]; [ "fst"; "snd" ]; [ "fst3"; "snd3"; "trd" ] ] ~f:(fun ts -> let ts = List.map ts ~f:of_string in print_s [%message (sep : t option) (ts : t list) ~concat:(concat ?sep ts : t)])); [%expect {| ((sep ()) (ts ()) (concat "")) ((sep ()) (ts (fst1)) (concat fst1)) ((sep ()) (ts (fst snd)) (concat fstsnd)) ((sep ()) (ts (fst3 snd3 trd)) (concat fst3snd3trd)) ((sep ("; ")) (ts ()) (concat "")) ((sep ("; ")) (ts (fst1)) (concat fst1)) ((sep ("; ")) (ts (fst snd)) (concat "fst; snd")) ((sep ("; ")) (ts (fst3 snd3 trd)) (concat "fst3; snd3; trd")) |}] ;; let equal = equal let compare = compare let%expect_test "basic equal" = let strings = [ ""; "a"; "aa"; "ab"; "b"; "ba"; "bb" ] in List.iter strings ~f:(fun s1 -> let t1 = of_string s1 in let test s2 = let t2 = of_string s2 in require_equal [%here] (module Bool) (equal t1 t2) (String.equal s1 s2) ~if_false_then_print_s:(lazy [%message (s1 : string) (s2 : string)]); require_equal [%here] (module Int) (compare t1 t2) (String.compare s1 s2) ~if_false_then_print_s:(lazy [%message (s1 : string) (s2 : string)]) in test s1; List.iter strings ~f:test) ;; type nonrec t = t type nonrec t_frozen = t_frozen [@@deriving compare, hash, sexp] (* Effectively tested in lib/int_repr *) module Int_repr = Base_bigstring.Int_repr base_bigstring-0.15.0/test/test_bigstring.mli000066400000000000000000000000461420273305200212660ustar00rootroot00000000000000include module type of Base_bigstring