Reindent all files

Now `make test` fails when sources are not indented correctly, the
indentation test is also executed in the CI.
This commit is contained in:
Pietro Abate 2017-11-13 16:34:00 +01:00 committed by Grégoire
parent 32a466556e
commit 6ecfca9396
112 changed files with 2096 additions and 2001 deletions

View File

@ -72,6 +72,11 @@ build:
dependencies: dependencies:
- build - build
test:ocp-indent:
<<: *test_definition
script:
- jbuilder build @runtest_indent
test:utils: test:utils:
<<: *test_definition <<: *test_definition
script: script:

62
jbuild
View File

@ -1 +1,63 @@
(jbuild_version 1) (jbuild_version 1)
(alias
((name runtest_indent)
(deps ( ;; Hack... list all directories
(glob_files scripts/*.ml)
(glob_files scripts/*.mli)
(glob_files src/*.ml)
(glob_files src/*.mli)
(glob_files src/attacker/*.ml)
(glob_files src/attacker/*.mli)
(glob_files src/client/*.ml)
(glob_files src/client/*.mli)
(glob_files src/client/embedded/alpha/*.ml)
(glob_files src/client/embedded/alpha/*.mli)
(glob_files src/client/embedded/demo/*.ml)
(glob_files src/client/embedded/demo/*.mli)
(glob_files src/client/embedded/genesis/*.ml)
(glob_files src/client/embedded/genesis/*.mli)
(glob_files src/compiler/*.ml)
(glob_files src/compiler/*.mli)
(glob_files src/environment/sigs_packer/*.ml)
(glob_files src/environment/sigs_packer/*.mli)
(glob_files src/environment/v1/*.ml)
(glob_files src/environment/v1/*.mli)
(glob_files src/micheline/*.ml)
(glob_files src/micheline/*.mli)
(glob_files src/minutils/*.ml)
(glob_files src/minutils/*.mli)
(glob_files src/node/db/*.ml)
(glob_files src/node/db/*.mli)
(glob_files src/node/main/*.ml)
(glob_files src/node/main/*.mli)
(glob_files src/node/net/*.ml)
(glob_files src/node/net/*.mli)
(glob_files src/node/shell/*.ml)
(glob_files src/node/shell/*.mli)
(glob_files src/node/updater/*.ml)
(glob_files src/node/updater/*.mli)
(glob_files src/proto/alpha/*.ml)
(glob_files src/proto/alpha/*.mli)
(glob_files src/proto/demo/*.ml)
(glob_files src/proto/demo/*.mli)
(glob_files src/proto/genesis/*.ml)
(glob_files src/proto/genesis/*.mli)
(glob_files src/utils/*.ml)
(glob_files src/utils/*.mli)
(glob_files test/lib/*.ml)
(glob_files test/lib/*.mli)
(glob_files test/p2p/*.ml)
(glob_files test/p2p/*.mli)
(glob_files test/proto_alpha/*.ml)
(glob_files test/proto_alpha/*.mli)
(glob_files test/shell/*.ml)
(glob_files test/shell/*.mli)
(glob_files test/utils/*.ml)
(glob_files test/utils/*.mli)
))
(action (run bash ${path:scripts/test-ocp-indent.sh}))))
(alias
((name runtest)
(deps ((alias runtest_indent)))))

22
scripts/test-ocp-indent.sh Executable file
View File

@ -0,0 +1,22 @@
#!/bin/sh
tmp_dir="$(mktemp -d -t tezos_build.XXXXXXXXXX)"
failed=no
for f in ` find \( -name _build -or \
-name .git -or \
-wholename ./src/environment/v1.ml -or \
-name registerer.ml \) -prune -or \
\( -name \*.ml -or -name \*.mli \) -print`; do
ff=$(basename $f)
ocp-indent $f > $tmp_dir/$ff
diff -u --color $f $tmp_dir/$ff
if [ $? -ne 0 ]; then
failed=yes
fi
rm -f $tmp_dir/$ff $tmp_dir/$ff.diff
done
if [ $failed = "yes" ]; then
exit 2
fi

View File

@ -34,10 +34,10 @@ let block_forged ?prev ops =
Proto.Fitness_repr.int64_to_bytes x ] in Proto.Fitness_repr.int64_to_bytes x ] in
let pred = match prev with None -> genesis_block_hashed | Some x -> x in let pred = match prev with None -> genesis_block_hashed | Some x -> x in
let block ops = Store.Block_header.{ net_id = network ; let block ops = Store.Block_header.{ net_id = network ;
predecessor = pred ; predecessor = pred ;
timestamp = Time.now () ; timestamp = Time.now () ;
fitness = from_int64 1L; fitness = from_int64 1L;
operations = ops } in operations = ops } in
let open Proto in let open Proto in
let generate_proof_of_work_nonce () = let generate_proof_of_work_nonce () =
Sodium.Random.Bigbytes.generate Sodium.Random.Bigbytes.generate
@ -70,12 +70,12 @@ let tx_forged ?dest amount fee =
parameters = None ; parameters = None ;
destination = default_contract trgt.public_key_hash ; } in destination = default_contract trgt.public_key_hash ; } in
let op = Sourced_operations let op = Sourced_operations
( Manager_operations ( Manager_operations
{ source = default_contract src.public_key_hash ; { source = default_contract src.public_key_hash ;
public_key = Some src.public_key ; public_key = Some src.public_key ;
fee = of_cents_exn fee ; fee = of_cents_exn fee ;
counter = 1l ; counter = 1l ;
operations = [tx] ; }) in operations = [tx] ; }) in
forge { net_id = network } op forge { net_id = network } op
(* forge a list of proposals, california eat your heart out *) (* forge a list of proposals, california eat your heart out *)
@ -98,7 +98,7 @@ let ballot_forged period prop vote =
period = period ; period = period ;
proposal = prop ; proposal = prop ;
ballot = vote ballot = vote
} in } in
let op = Sourced_operations (Delegate_operations { let op = Sourced_operations (Delegate_operations {
source = src.public_key ; source = src.public_key ;
operations = [ballot] }) in operations = [ballot] }) in

View File

@ -233,13 +233,13 @@ module Alias = functor (Entity : Entity) -> struct
iter_s iter_s
(fun (n, _v) -> (fun (n, _v) ->
if n = s then if n = s then
Entity.to_source cctxt _v >>=? fun value -> Entity.to_source cctxt _v >>=? fun value ->
failwith failwith
"@[<v 2>The %s alias %s already exists.@,\ "@[<v 2>The %s alias %s already exists.@,\
The current value is %s.@,\ The current value is %s.@,\
Use -force true to update@]" Use -force true to update@]"
Entity.name n Entity.name n
value value
else else
return ()) return ())
list list
@ -289,9 +289,9 @@ module Alias = functor (Entity : Entity) -> struct
end)) end))
next next
let name cctxt d = let name cctxt d =
rev_find cctxt d >>=? function rev_find cctxt d >>=? function
| None -> Entity.to_source cctxt d | None -> Entity.to_source cctxt d
| Some name -> return name | Some name -> return name
end end

View File

@ -162,9 +162,9 @@ let port_arg =
~default:(string_of_int Cfg_file.default.node_port) ~default:(string_of_int Cfg_file.default.node_port)
(parameter (parameter
(fun _ x -> try (fun _ x -> try
return (int_of_string x) return (int_of_string x)
with Failure _ -> with Failure _ ->
fail (Invalid_port_arg x))) fail (Invalid_port_arg x)))
let tls_switch = let tls_switch =
switch switch
~parameter:"-tls" ~parameter:"-tls"

View File

@ -53,5 +53,5 @@ let commands () = Cli_entries.[
) stream >>= fun () -> ) stream >>= fun () ->
cctxt.answer "Bootstrapped." >>= fun () -> cctxt.answer "Bootstrapped." >>= fun () ->
return () return ()
) )
] ]

View File

@ -45,7 +45,7 @@ let commands () =
| Ok hash -> | Ok hash ->
cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () -> cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash >>= fun () ->
return () return ()
| Error err -> | Error err ->
cctxt.error "Error while injecting protocol from %s: %a" cctxt.error "Error while injecting protocol from %s: %a"
dirname Error_monad.pp_print_error err >>= fun () -> dirname Error_monad.pp_print_error err >>= fun () ->
@ -66,8 +66,8 @@ let commands () =
Updater.extract (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () -> Updater.extract (Protocol_hash.to_short_b58check ph) ~hash:ph proto >>= fun () ->
cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () -> cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph >>= fun () ->
return () return ()
) ; ) ;
(* | Error err -> *) (* | Error err -> *)
(* cctxt.error "Error while dumping protocol %a: %a" *) (* cctxt.error "Error while dumping protocol %a: %a" *)
(* Protocol_hash.pp_short ph Error_monad.pp_print_error err); *) (* Protocol_hash.pp_short ph Error_monad.pp_print_error err); *)
] ]

View File

@ -109,14 +109,14 @@ let rpc_error_encoding =
(req "message" string)) (req "message" string))
(function Cannot_connect_to_RPC_server msg -> Some ((), msg) | _ -> None) (function Cannot_connect_to_RPC_server msg -> Some ((), msg) | _ -> None)
(function (), msg -> Cannot_connect_to_RPC_server msg) ; (function (), msg -> Cannot_connect_to_RPC_server msg) ;
case ~tag: 2 case ~tag: 2
(obj3 (obj3
(req "rpc_error_kind" (constant "request_failed")) (req "rpc_error_kind" (constant "request_failed"))
(req "path" (list string)) (req "path" (list string))
(req "http_code" (conv Cohttp.Code.code_of_status Cohttp.Code.status_of_code uint16))) (req "http_code" (conv Cohttp.Code.code_of_status Cohttp.Code.status_of_code uint16)))
(function Request_failed (path, code) -> Some ((), path, code) | _ -> None) (function Request_failed (path, code) -> Some ((), path, code) | _ -> None)
(function (), path, code -> Request_failed (path, code)) ; (function (), path, code -> Request_failed (path, code)) ;
case ~tag: 3 case ~tag: 3
(obj4 (obj4
(req "rpc_error_kind" (constant "malformed_json")) (req "rpc_error_kind" (constant "malformed_json"))
(req "path" (list string)) (req "path" (list string))
@ -124,7 +124,7 @@ let rpc_error_encoding =
(req "text" string)) (req "text" string))
(function Malformed_json (path, json, msg) -> Some ((), path, msg, json) | _ -> None) (function Malformed_json (path, json, msg) -> Some ((), path, msg, json) | _ -> None)
(function (), path, msg, json -> Malformed_json (path, json, msg)) ; (function (), path, msg, json -> Malformed_json (path, json, msg)) ;
case ~tag: 4 case ~tag: 4
(obj4 (obj4
(req "rpc_error_kind" (constant "unexpected_json")) (req "rpc_error_kind" (constant "unexpected_json"))
(req "path" (list string)) (req "path" (list string))

View File

@ -35,30 +35,30 @@ module Tags (Entity : Entity) = struct
include Client_aliases.Alias (struct include Client_aliases.Alias (struct
type t = Tag.t type t = Tag.t
let encoding = Tag.encoding let encoding = Tag.encoding
(* Split a string of tags separated by commas, and possibly spaces *) (* Split a string of tags separated by commas, and possibly spaces *)
let of_source _ tags_str = let of_source _ tags_str =
let rec aux tags s = let rec aux tags s =
try try
let idx = String.index s ',' in let idx = String.index s ',' in
let tag = String.(trim (sub s 0 idx)) in let tag = String.(trim (sub s 0 idx)) in
let tail = String.(sub s (idx + 1) (length s - (idx + 1))) in let tail = String.(sub s (idx + 1) (length s - (idx + 1))) in
aux (tag :: tags) tail aux (tag :: tags) tail
with with
| Not_found -> | Not_found ->
String.(trim s) :: tags String.(trim s) :: tags
in in
return (aux [] tags_str) return (aux [] tags_str)
let to_source _ tags = let to_source _ tags =
return (String.concat ", " tags) return (String.concat ", " tags)
let name = Entity.name ^ " tag" let name = Entity.name ^ " tag"
end) end)
let tag_param ?(name = "tag") ?(desc = "list of tags") next = let tag_param ?(name = "tag") ?(desc = "list of tags") next =
let desc = let desc =

View File

@ -45,7 +45,7 @@ let compare (bi1 : block_info) (bi2 : block_info) =
match Time.compare bi1.timestamp bi2.timestamp with match Time.compare bi1.timestamp bi2.timestamp with
| 0 -> Block_hash.compare bi1.predecessor bi2.predecessor | 0 -> Block_hash.compare bi1.predecessor bi2.predecessor
| x -> - x | x -> - x
end end
| x -> - x | x -> - x
end end
| x -> x | x -> x

View File

@ -244,7 +244,7 @@ let schedule_endorsements cctxt state bis =
then begin then begin
lwt_log_info lwt_log_info
"Schedule endorsement for block %a \ "Schedule endorsement for block %a \
\ (level %a, slot %d, time %a) (replace block %a)" \ (level %a, slot %d, time %a) (replace block %a)"
Block_hash.pp_short block.hash Block_hash.pp_short block.hash
Raw_level.pp level Raw_level.pp level
slot slot

View File

@ -92,8 +92,8 @@ let () =
pp_print_error err) pp_print_error err)
Data_encoding. Data_encoding.
(obj2 (obj2
(req "operation" (dynamic_size Client_node_rpcs.operation_encoding)) (req "operation" (dynamic_size Client_node_rpcs.operation_encoding))
(req "error" Node_rpc_services.Error.encoding)) (req "error" Node_rpc_services.Error.encoding))
(function (function
| Failed_to_preapply (hash, err) -> Some (hash, err) | Failed_to_preapply (hash, err) -> Some (hash, err)
| _ -> None) | _ -> None)
@ -147,7 +147,7 @@ let forge_block cctxt block
failwith "No slot found at level %a" Raw_level.pp level failwith "No slot found at level %a" Raw_level.pp level
end >>=? fun (priority, minimal_timestamp) -> end >>=? fun (priority, minimal_timestamp) ->
(* lwt_log_info "Baking block at level %a prio %d" *) (* lwt_log_info "Baking block at level %a prio %d" *)
(* Raw_level.pp level priority >>= fun () -> *) (* Raw_level.pp level priority >>= fun () -> *)
begin begin
match timestamp, minimal_timestamp with match timestamp, minimal_timestamp with
| None, timestamp -> return timestamp | None, timestamp -> return timestamp
@ -172,9 +172,9 @@ let forge_block cctxt block
lwt_log_info "Computed fitness %a" lwt_log_info "Computed fitness %a"
Fitness.pp shell_header.fitness >>= fun () -> Fitness.pp shell_header.fitness >>= fun () ->
if best_effort if best_effort
|| ( Operation_hash.Map.is_empty result.refused || ( Operation_hash.Map.is_empty result.refused
&& Operation_hash.Map.is_empty result.branch_refused && Operation_hash.Map.is_empty result.branch_refused
&& Operation_hash.Map.is_empty result.branch_delayed ) then && Operation_hash.Map.is_empty result.branch_delayed ) then
let operations = let operations =
if not best_effort then operations if not best_effort then operations
else else
@ -206,11 +206,11 @@ let forge_block cctxt block
(op, Operation_hash.Map.find h result.refused)) (op, Operation_hash.Map.find h result.refused))
with Not_found -> with Not_found ->
try Some (Failed_to_preapply try Some (Failed_to_preapply
(op, Operation_hash.Map.find h result.branch_refused)) (op, Operation_hash.Map.find h result.branch_refused))
with Not_found -> with Not_found ->
try Some (Failed_to_preapply try Some (Failed_to_preapply
(op, Operation_hash.Map.find h result.branch_delayed)) (op, Operation_hash.Map.find h result.branch_delayed))
with Not_found -> None) with Not_found -> None)
operations operations
@ -594,9 +594,9 @@ let create
(fun ppf bi -> (fun ppf bi ->
Block_hash.pp_short ppf bi.Client_baking_blocks.hash)) Block_hash.pp_short ppf bi.Client_baking_blocks.hash))
bis bis
>>= fun () -> >>= fun () ->
insert_blocks cctxt ?max_priority state bis >>= fun () -> insert_blocks cctxt ?max_priority state bis >>= fun () ->
worker_loop () worker_loop ()
end end
| `Endorsement (Some (Ok e)) -> | `Endorsement (Some (Ok e)) ->
Lwt.cancel timeout ; Lwt.cancel timeout ;
@ -617,6 +617,6 @@ let create
Lwt.return_unit Lwt.return_unit
end >>= fun () -> end >>= fun () ->
worker_loop () in worker_loop () in
lwt_log_info "Starting baking daemon" >>= fun () -> lwt_log_info "Starting baking daemon" >>= fun () ->
worker_loop () >>= fun () -> worker_loop () >>= fun () ->
return () return ()

View File

@ -109,7 +109,7 @@ let commands () =
[ [
command ~group ~desc: "Launch a daemon that handles delegate operations." command ~group ~desc: "Launch a daemon that handles delegate operations."
(args5 max_priority_arg endorsement_delay_arg (args5 max_priority_arg endorsement_delay_arg
Daemon.baking_switch Daemon.endorsement_switch Daemon.denunciation_switch) Daemon.baking_switch Daemon.endorsement_switch Daemon.denunciation_switch)
(prefixes [ "launch" ; "daemon" ] (prefixes [ "launch" ; "daemon" ]
@@ seq_of_param Client_keys.Public_key_hash.alias_param) @@ seq_of_param Client_keys.Public_key_hash.alias_param)
(fun (max_priority, endorsement_delay, baking, endorsement, denunciation) delegates cctxt -> (fun (max_priority, endorsement_delay, baking, endorsement, denunciation) delegates cctxt ->

View File

@ -28,7 +28,7 @@ let monitor cctxt ?contents ?check () =
| [proto] -> | [proto] ->
return { hash ; content = Some proto } return { hash ; content = Some proto }
| _ -> failwith "Error while parsing the operation") | _ -> failwith "Error while parsing the operation")
(List.concat ops) (List.concat ops)
in in
return (Lwt_stream.map_s convert ops_stream) return (Lwt_stream.map_s convert ops_stream)

View File

@ -101,10 +101,10 @@ module ContractAlias = struct
end))) end)))
next next
let name cctxt contract = let name cctxt contract =
rev_find cctxt contract >>=? function rev_find cctxt contract >>=? function
| None -> return (Contract.to_b58check contract) | None -> return (Contract.to_b58check contract)
| Some name -> return name | Some name -> return name
end end

View File

@ -68,7 +68,7 @@ let find cctxt block_hash =
let add cctxt block_hash nonce = let add cctxt block_hash nonce =
load cctxt >>= fun data -> load cctxt >>= fun data ->
save cctxt ((block_hash, nonce) :: save cctxt ((block_hash, nonce) ::
List.remove_assoc block_hash data) List.remove_assoc block_hash data)
let del cctxt block_hash = let del cctxt block_hash =
load cctxt >>= fun data -> load cctxt >>= fun data ->

View File

@ -176,11 +176,11 @@ module Helpers = struct
let baking_rights_for_delegate cctxt let baking_rights_for_delegate cctxt
b c ?max_priority ?first_level ?last_level () = b c ?max_priority ?first_level ?last_level () =
call_error_service2 cctxt Services.Helpers.Rights.baking_rights_for_delegate call_error_service2 cctxt Services.Helpers.Rights.baking_rights_for_delegate
b c (max_priority, first_level, last_level) b c (max_priority, first_level, last_level)
let endorsement_rights_for_delegate cctxt let endorsement_rights_for_delegate cctxt
b c ?max_priority ?first_level ?last_level () = b c ?max_priority ?first_level ?last_level () =
call_error_service2 cctxt Services.Helpers.Rights.endorsement_rights_for_delegate call_error_service2 cctxt Services.Helpers.Rights.endorsement_rights_for_delegate
b c (max_priority, first_level, last_level) b c (max_priority, first_level, last_level)
end end
module Forge = struct module Forge = struct
@ -246,10 +246,10 @@ module Helpers = struct
({net_id ; branch}, Sourced_operations op)) ({net_id ; branch}, Sourced_operations op))
let activate cctxt let activate cctxt
b ~net_id ~branch hash = b ~net_id ~branch hash =
operation cctxt b ~net_id ~branch (Activate hash) operation cctxt b ~net_id ~branch (Activate hash)
let activate_testnet cctxt let activate_testnet cctxt
b ~net_id ~branch hash = b ~net_id ~branch hash =
operation cctxt b ~net_id ~branch (Activate_testnet hash) operation cctxt b ~net_id ~branch (Activate_testnet hash)
end end
module Anonymous = struct module Anonymous = struct
let operations cctxt block ~net_id ~branch operations = let operations cctxt block ~net_id ~branch operations =
@ -286,11 +286,11 @@ module Helpers = struct
end end
(* type slot = *) (* type slot = *)
(* raw_level * int * timestamp option *) (* raw_level * int * timestamp option *)
(* let baking_possibilities *) (* let baking_possibilities *)
(* b c ?max_priority ?first_level ?last_level () = *) (* b c ?max_priority ?first_level ?last_level () = *)
(* call_error_service2 Services.Helpers.Context.Contract.baking_possibilities *) (* call_error_service2 Services.Helpers.Context.Contract.baking_possibilities *)
(* b c (max_priority, first_level, last_level) *) (* b c (max_priority, first_level, last_level) *)
(* (\* let endorsement_possibilities b c ?max_priority ?first_level ?last_level () = *\) *) (* (\* let endorsement_possibilities b c ?max_priority ?first_level ?last_level () = *\) *)
(* call_error_service2 Services.Helpers.Context.Contract.endorsement_possibilities *) (* call_error_service2 Services.Helpers.Context.Contract.endorsement_possibilities *)
(* b c (max_priority, first_level, last_level) *) (* b c (max_priority, first_level, last_level) *)

View File

@ -73,15 +73,15 @@ module Context : sig
module Nonce : sig module Nonce : sig
val hash: val hash:
Client_rpcs.config -> Client_rpcs.config ->
block -> Nonce_hash.t tzresult Lwt.t block -> Nonce_hash.t tzresult Lwt.t
type nonce_info = type nonce_info =
| Revealed of Nonce.t | Revealed of Nonce.t
| Missing of Nonce_hash.t | Missing of Nonce_hash.t
| Forgotten | Forgotten
val get: val get:
Client_rpcs.config -> Client_rpcs.config ->
block -> Raw_level.t -> nonce_info tzresult Lwt.t block -> Raw_level.t -> nonce_info tzresult Lwt.t
end end
module Key : sig module Key : sig
val get : val get :
@ -95,8 +95,8 @@ module Context : sig
end end
module Contract : sig module Contract : sig
val list: val list:
Client_rpcs.config -> Client_rpcs.config ->
block -> Contract.t list tzresult Lwt.t block -> Contract.t list tzresult Lwt.t
type info = { type info = {
manager: public_key_hash ; manager: public_key_hash ;
balance: Tez.t ; balance: Tez.t ;

View File

@ -386,11 +386,11 @@ let expand_asserts original =
| _ -> | _ ->
begin begin
match expand_compare remaining_prim with match expand_compare remaining_prim with
| None -> None | None -> None
| Some seq -> | Some seq ->
Some (Seq (loc, [ seq ; Some (Seq (loc, [ seq ;
Prim (loc, "IF", fail_false loc, None) ], None)) Prim (loc, "IF", fail_false loc, None) ], None))
end end
end end
| _ -> None | _ -> None
@ -618,11 +618,11 @@ let unexpand_unpaaiair expanded =
| Prim (_, "DIP", [ Seq (_, _, _) as sub ], None) :: rest -> | Prim (_, "DIP", [ Seq (_, _, _) as sub ], None) :: rest ->
destruct ("A" :: sacc) acc (sub :: rest) destruct ("A" :: sacc) acc (sub :: rest)
| Seq (_, [ Prim (_, "DUP", [], None) ; | Seq (_, [ Prim (_, "DUP", [], None) ;
Prim (_, "CAR", [], None) ; Prim (_, "CAR", [], None) ;
Prim (_, "DIP", Prim (_, "DIP",
[ Seq (_, [ Seq (_,
[ Prim (_, "CDR", [], None) ], None) ], [ Prim (_, "CDR", [], None) ], None) ],
None) ], None) :: rest -> None) ], None) :: rest ->
destruct [] (List.rev ("AI" :: sacc) :: acc) rest destruct [] (List.rev ("AI" :: sacc) :: acc) rest
| _ -> None in | _ -> None in
begin match destruct [] [ [ "R" ] ] nodes with begin match destruct [] [ [ "R" ] ] nodes with

View File

@ -101,7 +101,7 @@ let load_embeded_cmis cmis = List.iter load_embeded_cmi cmis
the protocol first-class module into the [Updater.versions] the protocol first-class module into the [Updater.versions]
hashtable). hashtable).
*) *)
let tezos_protocol_env = let tezos_protocol_env =

View File

@ -28,33 +28,33 @@ external length : 'a array -> int = "%array_length"
external get : 'a array -> int -> 'a = "%array_safe_get" external get : 'a array -> int -> 'a = "%array_safe_get"
(** [Array.get a n] returns the element number [n] of array [a]. (** [Array.get a n] returns the element number [n] of array [a].
The first element has number 0. The first element has number 0.
The last element has number [Array.length a - 1]. The last element has number [Array.length a - 1].
You can also write [a.(n)] instead of [Array.get a n]. You can also write [a.(n)] instead of [Array.get a n].
Raise [Invalid_argument "index out of bounds"] Raise [Invalid_argument "index out of bounds"]
if [n] is outside the range 0 to [(Array.length a - 1)]. *) if [n] is outside the range 0 to [(Array.length a - 1)]. *)
external set : 'a array -> int -> 'a -> unit = "%array_safe_set" external set : 'a array -> int -> 'a -> unit = "%array_safe_set"
(** [Array.set a n x] modifies array [a] in place, replacing (** [Array.set a n x] modifies array [a] in place, replacing
element number [n] with [x]. element number [n] with [x].
You can also write [a.(n) <- x] instead of [Array.set a n x]. You can also write [a.(n) <- x] instead of [Array.set a n x].
Raise [Invalid_argument "index out of bounds"] Raise [Invalid_argument "index out of bounds"]
if [n] is outside the range 0 to [Array.length a - 1]. *) if [n] is outside the range 0 to [Array.length a - 1]. *)
external make : int -> 'a -> 'a array = "caml_make_vect" external make : int -> 'a -> 'a array = "caml_make_vect"
(** [Array.make n x] returns a fresh array of length [n], (** [Array.make n x] returns a fresh array of length [n],
initialized with [x]. initialized with [x].
All the elements of this new array are initially All the elements of this new array are initially
physically equal to [x] (in the sense of the [==] predicate). physically equal to [x] (in the sense of the [==] predicate).
Consequently, if [x] is mutable, it is shared among all elements Consequently, if [x] is mutable, it is shared among all elements
of the array, and modifying [x] through one of the array entries of the array, and modifying [x] through one of the array entries
will modify all other entries at the same time. will modify all other entries at the same time.
Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
If the value of [x] is a floating-point number, then the maximum If the value of [x] is a floating-point number, then the maximum
size is only [Sys.max_array_length / 2].*) size is only [Sys.max_array_length / 2].*)
external create_float: int -> float array = "caml_make_float_vect" external create_float: int -> float array = "caml_make_float_vect"
(** [Array.create_float n] returns a fresh float array of length [n], (** [Array.create_float n] returns a fresh float array of length [n],
@ -63,71 +63,71 @@ external create_float: int -> float array = "caml_make_float_vect"
val init : int -> (int -> 'a) -> 'a array val init : int -> (int -> 'a) -> 'a array
(** [Array.init n f] returns a fresh array of length [n], (** [Array.init n f] returns a fresh array of length [n],
with element number [i] initialized to the result of [f i]. with element number [i] initialized to the result of [f i].
In other terms, [Array.init n f] tabulates the results of [f] In other terms, [Array.init n f] tabulates the results of [f]
applied to the integers [0] to [n-1]. applied to the integers [0] to [n-1].
Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length].
If the return type of [f] is [float], then the maximum If the return type of [f] is [float], then the maximum
size is only [Sys.max_array_length / 2].*) size is only [Sys.max_array_length / 2].*)
val make_matrix : int -> int -> 'a -> 'a array array val make_matrix : int -> int -> 'a -> 'a array array
(** [Array.make_matrix dimx dimy e] returns a two-dimensional array (** [Array.make_matrix dimx dimy e] returns a two-dimensional array
(an array of arrays) with first dimension [dimx] and (an array of arrays) with first dimension [dimx] and
second dimension [dimy]. All the elements of this new matrix second dimension [dimy]. All the elements of this new matrix
are initially physically equal to [e]. are initially physically equal to [e].
The element ([x,y]) of a matrix [m] is accessed The element ([x,y]) of a matrix [m] is accessed
with the notation [m.(x).(y)]. with the notation [m.(x).(y)].
Raise [Invalid_argument] if [dimx] or [dimy] is negative or Raise [Invalid_argument] if [dimx] or [dimy] is negative or
greater than [Sys.max_array_length]. greater than [Sys.max_array_length].
If the value of [e] is a floating-point number, then the maximum If the value of [e] is a floating-point number, then the maximum
size is only [Sys.max_array_length / 2]. *) size is only [Sys.max_array_length / 2]. *)
val append : 'a array -> 'a array -> 'a array val append : 'a array -> 'a array -> 'a array
(** [Array.append v1 v2] returns a fresh array containing the (** [Array.append v1 v2] returns a fresh array containing the
concatenation of the arrays [v1] and [v2]. *) concatenation of the arrays [v1] and [v2]. *)
val concat : 'a array list -> 'a array val concat : 'a array list -> 'a array
(** Same as [Array.append], but concatenates a list of arrays. *) (** Same as [Array.append], but concatenates a list of arrays. *)
val sub : 'a array -> int -> int -> 'a array val sub : 'a array -> int -> int -> 'a array
(** [Array.sub a start len] returns a fresh array of length [len], (** [Array.sub a start len] returns a fresh array of length [len],
containing the elements number [start] to [start + len - 1] containing the elements number [start] to [start + len - 1]
of array [a]. of array [a].
Raise [Invalid_argument "Array.sub"] if [start] and [len] do not Raise [Invalid_argument "Array.sub"] if [start] and [len] do not
designate a valid subarray of [a]; that is, if designate a valid subarray of [a]; that is, if
[start < 0], or [len < 0], or [start + len > Array.length a]. *) [start < 0], or [len < 0], or [start + len > Array.length a]. *)
val copy : 'a array -> 'a array val copy : 'a array -> 'a array
(** [Array.copy a] returns a copy of [a], that is, a fresh array (** [Array.copy a] returns a copy of [a], that is, a fresh array
containing the same elements as [a]. *) containing the same elements as [a]. *)
val fill : 'a array -> int -> int -> 'a -> unit val fill : 'a array -> int -> int -> 'a -> unit
(** [Array.fill a ofs len x] modifies the array [a] in place, (** [Array.fill a ofs len x] modifies the array [a] in place,
storing [x] in elements number [ofs] to [ofs + len - 1]. storing [x] in elements number [ofs] to [ofs + len - 1].
Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not Raise [Invalid_argument "Array.fill"] if [ofs] and [len] do not
designate a valid subarray of [a]. *) designate a valid subarray of [a]. *)
val blit : 'a array -> int -> 'a array -> int -> int -> unit val blit : 'a array -> int -> 'a array -> int -> int -> unit
(** [Array.blit v1 o1 v2 o2 len] copies [len] elements (** [Array.blit v1 o1 v2 o2 len] copies [len] elements
from array [v1], starting at element number [o1], to array [v2], from array [v1], starting at element number [o1], to array [v2],
starting at element number [o2]. It works correctly even if starting at element number [o2]. It works correctly even if
[v1] and [v2] are the same array, and the source and [v1] and [v2] are the same array, and the source and
destination chunks overlap. destination chunks overlap.
Raise [Invalid_argument "Array.blit"] if [o1] and [len] do not 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 [v1], or if [o2] and [len] do not
designate a valid subarray of [v2]. *) designate a valid subarray of [v2]. *)
val to_list : 'a array -> 'a list val to_list : 'a array -> 'a list
(** [Array.to_list a] returns the list of all the elements of [a]. *) (** [Array.to_list a] returns the list of all the elements of [a]. *)
val of_list : 'a list -> 'a array val of_list : 'a list -> 'a array
(** [Array.of_list l] returns a fresh array containing the elements (** [Array.of_list l] returns a fresh array containing the elements
of [l]. *) of [l]. *)
(** {6 Iterators} *) (** {6 Iterators} *)
@ -135,33 +135,33 @@ val of_list : 'a list -> 'a array
val iter : ('a -> unit) -> 'a array -> unit val iter : ('a -> unit) -> 'a array -> unit
(** [Array.iter f a] applies function [f] in turn to all (** [Array.iter f a] applies function [f] in turn to all
the elements of [a]. It is equivalent to the elements of [a]. It is equivalent to
[f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *) [f a.(0); f a.(1); ...; f a.(Array.length a - 1); ()]. *)
val iteri : (int -> 'a -> unit) -> 'a array -> unit val iteri : (int -> 'a -> unit) -> 'a array -> unit
(** Same as {!Array.iter}, but the (** Same as {!Array.iter}, but the
function is applied with the index of the element as first argument, function is applied with the index of the element as first argument,
and the element itself as second argument. *) and the element itself as second argument. *)
val map : ('a -> 'b) -> 'a array -> 'b array val map : ('a -> 'b) -> 'a array -> 'b array
(** [Array.map f a] applies function [f] to all the elements of [a], (** [Array.map f a] applies function [f] to all the elements of [a],
and builds an array with the results returned by [f]: and builds an array with the results returned by [f]:
[[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *) [[| f a.(0); f a.(1); ...; f a.(Array.length a - 1) |]]. *)
val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array val mapi : (int -> 'a -> 'b) -> 'a array -> 'b array
(** Same as {!Array.map}, but the (** Same as {!Array.map}, but the
function is applied to the index of the element as first argument, function is applied to the index of the element as first argument,
and the element itself as second argument. *) and the element itself as second argument. *)
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b array -> 'a
(** [Array.fold_left f x a] computes (** [Array.fold_left f x a] computes
[f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)],
where [n] is the length of the array [a]. *) where [n] is the length of the array [a]. *)
val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
(** [Array.fold_right f a x] computes (** [Array.fold_right f a x] computes
[f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))],
where [n] is the length of the array [a]. *) where [n] is the length of the array [a]. *)
(** {6 Iterators on two arrays} *) (** {6 Iterators on two arrays} *)
@ -169,16 +169,16 @@ val fold_right : ('b -> 'a -> 'a) -> 'b array -> 'a -> 'a
val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit val iter2 : ('a -> 'b -> unit) -> 'a array -> 'b array -> unit
(** [Array.iter2 f a b] applies function [f] to all the elements of [a] (** [Array.iter2 f a b] applies function [f] to all the elements of [a]
and [b]. and [b].
Raise [Invalid_argument] if the arrays are not the same size. Raise [Invalid_argument] if the arrays are not the same size.
@since 4.03.0 *) @since 4.03.0 *)
val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
(** [Array.map2 f a b] applies function [f] to all the elements of [a] (** [Array.map2 f a b] applies function [f] to all the elements of [a]
and [b], and builds an array with the results returned by [f]: and [b], and builds an array with the results returned by [f]:
[[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]]. [[| f a.(0) b.(0); ...; f a.(Array.length a - 1) b.(Array.length b - 1)|]].
Raise [Invalid_argument] if the arrays are not the same size. Raise [Invalid_argument] if the arrays are not the same size.
@since 4.03.0 *) @since 4.03.0 *)
(** {6 Array scanning} *) (** {6 Array scanning} *)
@ -186,9 +186,9 @@ val map2 : ('a -> 'b -> 'c) -> 'a array -> 'b array -> 'c array
val for_all : ('a -> bool) -> 'a array -> bool val for_all : ('a -> bool) -> 'a array -> bool
(** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array (** [Array.for_all p [|a1; ...; an|]] checks if all elements of the array
satisfy the predicate [p]. That is, it returns satisfy the predicate [p]. That is, it returns
[(p a1) && (p a2) && ... && (p an)]. [(p a1) && (p a2) && ... && (p an)].
@since 4.03.0 *) @since 4.03.0 *)
val exists : ('a -> bool) -> 'a array -> bool val exists : ('a -> bool) -> 'a array -> bool
(** [Array.exists p [|a1; ...; an|]] checks if at least one element of (** [Array.exists p [|a1; ...; an|]] checks if at least one element of
@ -198,13 +198,13 @@ val exists : ('a -> bool) -> 'a array -> bool
val mem : 'a -> 'a array -> bool val mem : 'a -> 'a array -> bool
(** [mem a l] is true if and only if [a] is equal (** [mem a l] is true if and only if [a] is equal
to an element of [l]. to an element of [l].
@since 4.03.0 *) @since 4.03.0 *)
val memq : 'a -> 'a array -> bool val memq : 'a -> 'a array -> bool
(** Same as {!Array.mem}, but uses physical equality instead of structural (** Same as {!Array.mem}, but uses physical equality instead of structural
equality to compare array elements. equality to compare array elements.
@since 4.03.0 *) @since 4.03.0 *)
(** {6 Sorting} *) (** {6 Sorting} *)
@ -212,38 +212,38 @@ val memq : 'a -> 'a array -> bool
val sort : ('a -> 'a -> int) -> 'a array -> unit val sort : ('a -> 'a -> int) -> 'a array -> unit
(** Sort an array in increasing order according to a comparison (** Sort an array in increasing order according to a comparison
function. The comparison function must return 0 if its arguments function. The comparison function must return 0 if its arguments
compare as equal, a positive integer if the first is greater, compare as equal, a positive integer if the first is greater,
and a negative integer if the first is smaller (see below for a and a negative integer if the first is smaller (see below for a
complete specification). For example, {!Pervasives.compare} is complete specification). For example, {!Pervasives.compare} is
a suitable comparison function, provided there are no floating-point a suitable comparison function, provided there are no floating-point
NaN values in the data. After calling [Array.sort], the NaN values in the data. After calling [Array.sort], the
array is sorted in place in increasing order. array is sorted in place in increasing order.
[Array.sort] is guaranteed to run in constant heap space [Array.sort] is guaranteed to run in constant heap space
and (at most) logarithmic stack space. and (at most) logarithmic stack space.
The current implementation uses Heap Sort. It runs in constant The current implementation uses Heap Sort. It runs in constant
stack space. stack space.
Specification of the comparison function: Specification of the comparison function:
Let [a] be the array and [cmp] the comparison function. The following Let [a] be the array and [cmp] the comparison function. The following
must be true for all x, y, z in a : must be true for all x, y, z in a :
- [cmp x y] > 0 if and only if [cmp y x] < 0 - [cmp x y] > 0 if and only if [cmp y x] < 0
- if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0 - if [cmp x y] >= 0 and [cmp y z] >= 0 then [cmp x z] >= 0
When [Array.sort] returns, [a] contains the same elements as before, When [Array.sort] returns, [a] contains the same elements as before,
reordered in such a way that for all i and j valid indices of [a] : reordered in such a way that for all i and j valid indices of [a] :
- [cmp a.(i) a.(j)] >= 0 if and only if i >= j - [cmp a.(i) a.(j)] >= 0 if and only if i >= j
*) *)
val stable_sort : ('a -> 'a -> int) -> 'a array -> unit val stable_sort : ('a -> 'a -> int) -> 'a array -> unit
(** Same as {!Array.sort}, but the sorting algorithm is stable (i.e. (** Same as {!Array.sort}, but the sorting algorithm is stable (i.e.
elements that compare equal are kept in their original order) and elements that compare equal are kept in their original order) and
not guaranteed to run in constant heap space. not guaranteed to run in constant heap space.
The current implementation uses Merge Sort. It uses [n/2] The current implementation uses Merge Sort. It uses [n/2]
words of heap space, where [n] is the length of the array. words of heap space, where [n] is the length of the array.
It is usually faster than the current implementation of {!Array.sort}. It is usually faster than the current implementation of {!Array.sort}.
*) *)
val fast_sort : ('a -> 'a -> int) -> 'a array -> unit val fast_sort : ('a -> 'a -> int) -> 'a array -> unit

View File

@ -22,10 +22,10 @@
(** Extensible buffers. (** Extensible buffers.
This module implements buffers that automatically expand This module implements buffers that automatically expand
as necessary. It provides accumulative concatenation of strings as necessary. It provides accumulative concatenation of strings
in quasi-linear time (instead of quadratic time when strings are in quasi-linear time (instead of quadratic time when strings are
concatenated pairwise). concatenated pairwise).
*) *)
type t type t
@ -33,17 +33,17 @@ type t
val create : int -> t val create : int -> t
(** [create n] returns a fresh buffer, initially empty. (** [create n] returns a fresh buffer, initially empty.
The [n] parameter is the initial size of the internal byte sequence The [n] parameter is the initial size of the internal byte sequence
that holds the buffer contents. That byte sequence is automatically that holds the buffer contents. That byte sequence is automatically
reallocated when more than [n] characters are stored in the buffer, reallocated when more than [n] characters are stored in the buffer,
but shrinks back to [n] characters when [reset] is called. but shrinks back to [n] characters when [reset] is called.
For best performance, [n] should be of the same order of magnitude For best performance, [n] should be of the same order of magnitude
as the number of characters that are expected to be stored in as the number of characters that are expected to be stored in
the buffer (for instance, 80 for a buffer that holds one output the buffer (for instance, 80 for a buffer that holds one output
line). Nothing bad will happen if the buffer grows beyond that line). Nothing bad will happen if the buffer grows beyond that
limit, however. In doubt, take [n = 16] for instance. limit, however. In doubt, take [n = 16] for instance.
If [n] is not between 1 and {!Sys.max_string_length}, it will If [n] is not between 1 and {!Sys.max_string_length}, it will
be clipped to that interval. *) be clipped to that interval. *)
val contents : t -> string val contents : t -> string
(** Return a copy of the current contents of the buffer. (** Return a copy of the current contents of the buffer.
@ -63,13 +63,13 @@ val sub : t -> int -> int -> string
val blit : t -> int -> bytes -> int -> int -> unit val blit : t -> int -> bytes -> int -> int -> unit
(** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from (** [Buffer.blit src srcoff dst dstoff len] copies [len] characters from
the current contents of the buffer [src], starting at offset [srcoff] the current contents of the buffer [src], starting at offset [srcoff]
to [dst], starting at character [dstoff]. to [dst], starting at character [dstoff].
Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid Raise [Invalid_argument] if [srcoff] and [len] do not designate a valid
range of [src], or if [dstoff] and [len] do not designate a valid range of [src], or if [dstoff] and [len] do not designate a valid
range of [dst]. range of [dst].
@since 3.11.2 @since 3.11.2
*) *)
val nth : t -> int -> char val nth : t -> int -> char
@ -84,10 +84,10 @@ val clear : t -> unit
val reset : t -> unit val reset : t -> unit
(** Empty the buffer and deallocate the internal byte sequence holding the (** Empty the buffer and deallocate the internal byte sequence holding the
buffer contents, replacing it with the initial internal byte sequence buffer contents, replacing it with the initial internal byte sequence
of length [n] that was allocated by {!Buffer.create} [n]. of length [n] that was allocated by {!Buffer.create} [n].
For long-lived buffers that may have grown a lot, [reset] allows For long-lived buffers that may have grown a lot, [reset] allows
faster reclamation of the space used by the buffer. *) faster reclamation of the space used by the buffer. *)
val add_char : t -> char -> unit val add_char : t -> char -> unit
(** [add_char b c] appends the character [c] at the end of buffer [b]. *) (** [add_char b c] appends the character [c] at the end of buffer [b]. *)
@ -101,7 +101,7 @@ val add_bytes : t -> bytes -> unit
val add_substring : t -> string -> int -> int -> unit val add_substring : t -> string -> int -> int -> unit
(** [add_substring b s ofs len] takes [len] characters from offset (** [add_substring b s ofs len] takes [len] characters from offset
[ofs] in string [s] and appends them at the end of buffer [b]. *) [ofs] in string [s] and appends them at the end of buffer [b]. *)
val add_subbytes : t -> bytes -> int -> int -> unit val add_subbytes : t -> bytes -> int -> int -> unit
(** [add_subbytes b s ofs len] takes [len] characters from offset (** [add_subbytes b s ofs len] takes [len] characters from offset
@ -110,20 +110,20 @@ val add_subbytes : t -> bytes -> int -> int -> unit
val add_substitute : t -> (string -> string) -> string -> unit val add_substitute : t -> (string -> string) -> string -> unit
(** [add_substitute b f s] appends the string pattern [s] at the end (** [add_substitute b f s] appends the string pattern [s] at the end
of buffer [b] with substitution. of buffer [b] with substitution.
The substitution process looks for variables into The substitution process looks for variables into
the pattern and substitutes each variable name by its value, as the pattern and substitutes each variable name by its value, as
obtained by applying the mapping [f] to the variable name. Inside the obtained by applying the mapping [f] to the variable name. Inside the
string pattern, a variable name immediately follows a non-escaped string pattern, a variable name immediately follows a non-escaped
[$] character and is one of the following: [$] character and is one of the following:
- a non empty sequence of alphanumeric or [_] characters, - a non empty sequence of alphanumeric or [_] characters,
- an arbitrary sequence of characters enclosed by a pair of - an arbitrary sequence of characters enclosed by a pair of
matching parentheses or curly brackets. matching parentheses or curly brackets.
An escaped [$] character is a [$] that immediately follows a backslash An escaped [$] character is a [$] that immediately follows a backslash
character; it then stands for a plain [$]. character; it then stands for a plain [$].
Raise [Not_found] if the closing character of a parenthesized variable Raise [Not_found] if the closing character of a parenthesized variable
cannot be found. *) cannot be found. *)
val add_buffer : t -> t -> unit val add_buffer : t -> t -> unit
(** [add_buffer b1 b2] appends the current contents of buffer [b2] (** [add_buffer b1 b2] appends the current contents of buffer [b2]
at the end of buffer [b1]. [b2] is not modified. *) at the end of buffer [b1]. [b2] is not modified. *)

View File

@ -24,32 +24,32 @@
(** Byte sequence operations. (** Byte sequence operations.
A byte sequence is a mutable data structure that contains a A byte sequence is a mutable data structure that contains a
fixed-length sequence of bytes. Each byte can be indexed in fixed-length sequence of bytes. Each byte can be indexed in
constant time for reading or writing. constant time for reading or writing.
Given a byte sequence [s] of length [l], we can access each of the Given a byte sequence [s] of length [l], we can access each of the
[l] bytes of [s] via its index in the sequence. Indexes start at [l] bytes of [s] via its index in the sequence. Indexes start at
[0], and we will call an index valid in [s] if it falls within the [0], and we will call an index valid in [s] if it falls within the
range [[0...l-1]] (inclusive). A position is the point between two range [[0...l-1]] (inclusive). A position is the point between two
bytes or at the beginning or end of the sequence. We call a bytes or at the beginning or end of the sequence. We call a
position valid in [s] if it falls within the range [[0...l]] position valid in [s] if it falls within the range [[0...l]]
(inclusive). Note that the byte at index [n] is between positions (inclusive). Note that the byte at index [n] is between positions
[n] and [n+1]. [n] and [n+1].
Two parameters [start] and [len] are said to designate a valid Two parameters [start] and [len] are said to designate a valid
range of [s] if [len >= 0] and [start] and [start+len] are valid range of [s] if [len >= 0] and [start] and [start+len] are valid
positions in [s]. positions in [s].
Byte sequences can be modified in place, for instance via the [set] Byte sequences can be modified in place, for instance via the [set]
and [blit] functions described below. See also strings (module and [blit] functions described below. See also strings (module
{!String}), which are almost the same data structure, but cannot be {!String}), which are almost the same data structure, but cannot be
modified in place. modified in place.
Bytes are represented by the OCaml type [char]. Bytes are represented by the OCaml type [char].
@since 4.02.0 @since 4.02.0
*) *)
external length : bytes -> int = "%bytes_length" external length : bytes -> int = "%bytes_length"
(** Return the length (number of bytes) of the argument. *) (** Return the length (number of bytes) of the argument. *)
@ -243,23 +243,23 @@ val rcontains_from : bytes -> int -> char -> bool
val uppercase_ascii : bytes -> bytes val uppercase_ascii : bytes -> bytes
(** Return a copy of the argument, with all lowercase letters (** Return a copy of the argument, with all lowercase letters
translated to uppercase, using the US-ASCII character set. translated to uppercase, using the US-ASCII character set.
@since 4.03.0 *) @since 4.03.0 *)
val lowercase_ascii : bytes -> bytes val lowercase_ascii : bytes -> bytes
(** Return a copy of the argument, with all uppercase letters (** Return a copy of the argument, with all uppercase letters
translated to lowercase, using the US-ASCII character set. translated to lowercase, using the US-ASCII character set.
@since 4.03.0 *) @since 4.03.0 *)
val capitalize_ascii : bytes -> bytes val capitalize_ascii : bytes -> bytes
(** Return a copy of the argument, with the first character set to uppercase, (** Return a copy of the argument, with the first character set to uppercase,
using the US-ASCII character set. using the US-ASCII character set.
@since 4.03.0 *) @since 4.03.0 *)
val uncapitalize_ascii : bytes -> bytes val uncapitalize_ascii : bytes -> bytes
(** Return a copy of the argument, with the first character set to lowercase, (** Return a copy of the argument, with the first character set to lowercase,
using the US-ASCII character set. using the US-ASCII character set.
@since 4.03.0 *) @since 4.03.0 *)
type t = bytes type t = bytes
(** An alias for the type of byte sequences. *) (** An alias for the type of byte sequences. *)

View File

@ -24,63 +24,63 @@
(** Pretty printing. (** Pretty printing.
This module implements a pretty-printing facility to format values This module implements a pretty-printing facility to format values
within 'pretty-printing boxes'. The pretty-printer splits lines within 'pretty-printing boxes'. The pretty-printer splits lines
at specified break hints, and indents lines according to the box at specified break hints, and indents lines according to the box
structure. structure.
For a gentle introduction to the basics of pretty-printing using For a gentle introduction to the basics of pretty-printing using
[Format], read [Format], read
{{:http://caml.inria.fr/resources/doc/guides/format.en.html} {{:http://caml.inria.fr/resources/doc/guides/format.en.html}
http://caml.inria.fr/resources/doc/guides/format.en.html}. http://caml.inria.fr/resources/doc/guides/format.en.html}.
You may consider this module as providing an extension to the You may consider this module as providing an extension to the
[printf] facility to provide automatic line splitting. The addition of [printf] facility to provide automatic line splitting. The addition of
pretty-printing annotations to your regular [printf] formats gives you pretty-printing annotations to your regular [printf] formats gives you
fancy indentation and line breaks. fancy indentation and line breaks.
Pretty-printing annotations are described below in the documentation of Pretty-printing annotations are described below in the documentation of
the function {!Format.fprintf}. the function {!Format.fprintf}.
You may also use the explicit box management and printing functions You may also use the explicit box management and printing functions
provided by this module. This style is more basic but more verbose provided by this module. This style is more basic but more verbose
than the [fprintf] concise formats. than the [fprintf] concise formats.
For instance, the sequence For instance, the sequence
[open_box 0; print_string "x ="; print_space (); [open_box 0; print_string "x ="; print_space ();
print_int 1; close_box (); print_newline ()] print_int 1; close_box (); print_newline ()]
that prints [x = 1] within a pretty-printing box, can be that prints [x = 1] within a pretty-printing box, can be
abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter abbreviated as [printf "@[%s@ %i@]@." "x =" 1], or even shorter
[printf "@[x =@ %i@]@." 1]. [printf "@[x =@ %i@]@." 1].
Rule of thumb for casual users of this library: Rule of thumb for casual users of this library:
- use simple boxes (as obtained by [open_box 0]); - use simple boxes (as obtained by [open_box 0]);
- use simple break hints (as obtained by [print_cut ()] that outputs a - use simple break hints (as obtained by [print_cut ()] that outputs a
simple break hint, or by [print_space ()] that outputs a space simple break hint, or by [print_space ()] that outputs a space
indicating a break hint); indicating a break hint);
- once a box is opened, display its material with basic printing - once a box is opened, display its material with basic printing
functions (e. g. [print_int] and [print_string]); functions (e. g. [print_int] and [print_string]);
- when the material for a box has been printed, call [close_box ()] to - when the material for a box has been printed, call [close_box ()] to
close the box; close the box;
- at the end of your routine, flush the pretty-printer to display all the - at the end of your routine, flush the pretty-printer to display all the
remaining material, e.g. evaluate [print_newline ()]. remaining material, e.g. evaluate [print_newline ()].
The behaviour of pretty-printing commands is unspecified The behaviour of pretty-printing commands is unspecified
if there is no opened pretty-printing box. Each box opened via if there is no opened pretty-printing box. Each box opened via
one of the [open_] functions below must be closed using [close_box] one of the [open_] functions below must be closed using [close_box]
for proper formatting. Otherwise, some of the material printed in the for proper formatting. Otherwise, some of the material printed in the
boxes may not be output, or may be formatted incorrectly. boxes may not be output, or may be formatted incorrectly.
In case of interactive use, the system closes all opened boxes and In case of interactive use, the system closes all opened boxes and
flushes all pending text (as with the [print_newline] function) flushes all pending text (as with the [print_newline] function)
after each phrase. Each phrase is therefore executed in the initial after each phrase. Each phrase is therefore executed in the initial
state of the pretty-printer. state of the pretty-printer.
Warning: the material output by the following functions is delayed Warning: the material output by the following functions is delayed
in the pretty-printer queue in order to compute the proper line in the pretty-printer queue in order to compute the proper line
splitting. Hence, you should not mix calls to the printing functions splitting. Hence, you should not mix calls to the printing functions
of the basic I/O system with calls to the functions of this module: of the basic I/O system with calls to the functions of this module:
this could result in some strange output seemingly unrelated with this could result in some strange output seemingly unrelated with
the evaluation order of printing commands. the evaluation order of printing commands.
*) *)
(** {6:tags Semantic Tags} *) (** {6:tags Semantic Tags} *)
@ -90,9 +90,9 @@ type tag = string
(** {6:meaning Changing the meaning of standard formatter pretty printing} *) (** {6:meaning Changing the meaning of standard formatter pretty printing} *)
(** The [Format] module is versatile enough to let you completely redefine (** The [Format] module is versatile enough to let you completely redefine
the meaning of pretty printing: you may provide your own functions to define the meaning of pretty printing: you may provide your own functions to define
how to handle indentation, line splitting, and even printing of all the how to handle indentation, line splitting, and even printing of all the
characters that have to be printed! *) characters that have to be printed! *)
type formatter_out_functions = { type formatter_out_functions = {
out_string : string -> int -> int -> unit; out_string : string -> int -> int -> unit;
@ -110,44 +110,44 @@ type formatter_tag_functions = {
print_close_tag : tag -> unit; print_close_tag : tag -> unit;
} }
(** The tag handling functions specific to a formatter: (** The tag handling functions specific to a formatter:
[mark] versions are the 'tag marking' functions that associate a string [mark] versions are the 'tag marking' functions that associate a string
marker to a tag in order for the pretty-printing engine to flush marker to a tag in order for the pretty-printing engine to flush
those markers as 0 length tokens in the output device of the formatter. those markers as 0 length tokens in the output device of the formatter.
[print] versions are the 'tag printing' functions that can perform [print] versions are the 'tag printing' functions that can perform
regular printing when a tag is closed or opened. *) regular printing when a tag is closed or opened. *)
(** {6 Multiple formatted output} *) (** {6 Multiple formatted output} *)
type formatter type formatter
(** Abstract data corresponding to a pretty-printer (also called a (** Abstract data corresponding to a pretty-printer (also called a
formatter) and all its machinery. formatter) and all its machinery.
Defining new pretty-printers permits unrelated output of material in Defining new pretty-printers permits unrelated output of material in
parallel on several output channels. parallel on several output channels.
All the parameters of a pretty-printer are local to a formatter: All the parameters of a pretty-printer are local to a formatter:
margin, maximum indentation limit, maximum number of boxes margin, maximum indentation limit, maximum number of boxes
simultaneously opened, ellipsis, and so on, are specific to simultaneously opened, ellipsis, and so on, are specific to
each pretty-printer and may be fixed independently. each pretty-printer and may be fixed independently.
Given a [Pervasives.out_channel] output channel [oc], a new formatter Given a [Pervasives.out_channel] output channel [oc], a new formatter
writing to that channel is simply obtained by calling writing to that channel is simply obtained by calling
[formatter_of_out_channel oc]. [formatter_of_out_channel oc].
Alternatively, the [make_formatter] function allocates a new Alternatively, the [make_formatter] function allocates a new
formatter with explicit output and flushing functions formatter with explicit output and flushing functions
(convenient to output material to strings for instance). (convenient to output material to strings for instance).
*) *)
val formatter_of_buffer : Buffer.t -> formatter val formatter_of_buffer : Buffer.t -> formatter
(** [formatter_of_buffer b] returns a new formatter writing to (** [formatter_of_buffer b] returns a new formatter writing to
buffer [b]. As usual, the formatter has to be flushed at buffer [b]. As usual, the formatter has to be flushed at
the end of pretty printing, using [pp_print_flush] or the end of pretty printing, using [pp_print_flush] or
[pp_print_newline], to display all the pending material. *) [pp_print_newline], to display all the pending material. *)
val make_formatter : val make_formatter :
(string -> int -> int -> unit) -> (unit -> unit) -> formatter (string -> int -> int -> unit) -> (unit -> unit) -> formatter
(** [make_formatter out flush] returns a new formatter that writes according (** [make_formatter out flush] returns a new formatter that writes according
to the output function [out], and the flushing function [flush]. For to the output function [out], and the flushing function [flush]. For
instance, a formatter to the [Pervasives.out_channel] [oc] is returned by instance, a formatter to the [Pervasives.out_channel] [oc] is returned by
[make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *) [make_formatter (Pervasives.output oc) (fun () -> Pervasives.flush oc)]. *)
(** {6 Basic functions to use with formatters} *) (** {6 Basic functions to use with formatters} *)
@ -205,9 +205,9 @@ val pp_set_formatter_out_functions :
val pp_get_formatter_out_functions : val pp_get_formatter_out_functions :
formatter -> unit -> formatter_out_functions formatter -> unit -> formatter_out_functions
(** These functions are the basic ones: usual functions (** These functions are the basic ones: usual functions
operating on the standard formatter are defined via partial operating on the standard formatter are defined via partial
evaluation of these primitives. For instance, evaluation of these primitives. For instance,
[print_string] is equal to [pp_print_string std_formatter]. *) [print_string] is equal to [pp_print_string std_formatter]. *)
val pp_flush_formatter : formatter -> unit val pp_flush_formatter : formatter -> unit
(** [pp_flush_formatter fmt] flushes [fmt]'s internal queue, ensuring that all (** [pp_flush_formatter fmt] flushes [fmt]'s internal queue, ensuring that all
@ -223,19 +223,19 @@ val pp_print_list:
?pp_sep:(formatter -> unit -> unit) -> ?pp_sep:(formatter -> unit -> unit) ->
(formatter -> 'a -> unit) -> (formatter -> 'a list -> unit) (formatter -> 'a -> unit) -> (formatter -> 'a list -> unit)
(** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l], (** [pp_print_list ?pp_sep pp_v ppf l] prints items of list [l],
using [pp_v] to print each item, and calling [pp_sep] using [pp_v] to print each item, and calling [pp_sep]
between items ([pp_sep] defaults to {!pp_print_cut}). between items ([pp_sep] defaults to {!pp_print_cut}).
Does nothing on empty lists. Does nothing on empty lists.
@since 4.02.0 @since 4.02.0
*) *)
val pp_print_text : formatter -> string -> unit val pp_print_text : formatter -> string -> unit
(** [pp_print_text ppf s] prints [s] with spaces and newlines (** [pp_print_text ppf s] prints [s] with spaces and newlines
respectively printed with {!pp_print_space} and respectively printed with {!pp_print_space} and
{!pp_force_newline}. {!pp_force_newline}.
@since 4.02.0 @since 4.02.0
*) *)
(** {6 [printf] like functions for pretty-printing.} *) (** {6 [printf] like functions for pretty-printing.} *)
@ -243,17 +243,17 @@ val pp_print_text : formatter -> string -> unit
val fprintf : formatter -> ('a, formatter, unit) format -> 'a val fprintf : formatter -> ('a, formatter, unit) format -> 'a
(** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN] (** [fprintf ff fmt arg1 ... argN] formats the arguments [arg1] to [argN]
according to the format string [fmt], and outputs the resulting string on according to the format string [fmt], and outputs the resulting string on
the formatter [ff]. the formatter [ff].
The format [fmt] is a character string which contains three types of The format [fmt] is a character string which contains three types of
objects: plain characters and conversion specifications as specified in objects: plain characters and conversion specifications as specified in
the [Printf] module, and pretty-printing indications specific to the the [Printf] module, and pretty-printing indications specific to the
[Format] module. [Format] module.
The pretty-printing indication characters are introduced by The pretty-printing indication characters are introduced by
a [@] character, and their meanings are: a [@] character, and their meanings are:
- [@\[]: open a pretty-printing box. The type and offset of the - [@\[]: open a pretty-printing box. The type and offset of the
box may be optionally specified with the following syntax: box may be optionally specified with the following syntax:
the [<] character, followed by an optional box type indication, the [<] character, followed by an optional box type indication,
then an optional integer offset, and the closing [>] character. then an optional integer offset, and the closing [>] character.
@ -267,24 +267,24 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a
box with indentation 2 as obtained with [open_hovbox 2]. box with indentation 2 as obtained with [open_hovbox 2].
For more details about boxes, see the various box opening For more details about boxes, see the various box opening
functions [open_*box]. functions [open_*box].
- [@\]]: close the most recently opened pretty-printing box. - [@\]]: close the most recently opened pretty-printing box.
- [@,]: output a 'cut' break hint, as with [print_cut ()]. - [@,]: output a 'cut' break hint, as with [print_cut ()].
- [@ ]: output a 'space' break hint, as with [print_space ()]. - [@ ]: output a 'space' break hint, as with [print_space ()].
- [@;]: output a 'full' break hint as with [print_break]. The - [@;]: output a 'full' break hint as with [print_break]. The
[nspaces] and [offset] parameters of the break hint may be [nspaces] and [offset] parameters of the break hint may be
optionally specified with the following syntax: optionally specified with the following syntax:
the [<] character, followed by an integer [nspaces] value, the [<] character, followed by an integer [nspaces] value,
then an integer [offset], and a closing [>] character. then an integer [offset], and a closing [>] character.
If no parameters are provided, the good break defaults to a If no parameters are provided, the good break defaults to a
'space' break hint. 'space' break hint.
- [@.]: flush the pretty printer and split the line, as with - [@.]: flush the pretty printer and split the line, as with
[print_newline ()]. [print_newline ()].
- [@<n>]: print the following item as if it were of length [n]. - [@<n>]: print the following item as if it were of length [n].
Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string. Hence, [printf "@<0>%s" arg] prints [arg] as a zero length string.
If [@<n>] is not followed by a conversion specification, If [@<n>] is not followed by a conversion specification,
then the following character of the format is printed as if then the following character of the format is printed as if
it were of length [n]. it were of length [n].
- [@\{]: open a tag. The name of the tag may be optionally - [@\{]: open a tag. The name of the tag may be optionally
specified with the following syntax: specified with the following syntax:
the [<] character, followed by an optional string the [<] character, followed by an optional string
specification, and the closing [>] character. The string specification, and the closing [>] character. The string
@ -293,53 +293,53 @@ val fprintf : formatter -> ('a, formatter, unit) format -> 'a
empty string. empty string.
For more details about tags, see the functions [open_tag] and For more details about tags, see the functions [open_tag] and
[close_tag]. [close_tag].
- [@\}]: close the most recently opened tag. - [@\}]: close the most recently opened tag.
- [@?]: flush the pretty printer as with [print_flush ()]. - [@?]: flush the pretty printer as with [print_flush ()].
This is equivalent to the conversion [%!]. This is equivalent to the conversion [%!].
- [@\n]: force a newline, as with [force_newline ()], not the normal way - [@\n]: force a newline, as with [force_newline ()], not the normal way
of pretty-printing, you should prefer using break hints inside a vertical of pretty-printing, you should prefer using break hints inside a vertical
box. box.
Note: If you need to prevent the interpretation of a [@] character as a Note: If you need to prevent the interpretation of a [@] character as a
pretty-printing indication, you must escape it with a [%] character. pretty-printing indication, you must escape it with a [%] character.
Old quotation mode [@@] is deprecated since it is not compatible with Old quotation mode [@@] is deprecated since it is not compatible with
formatted input interpretation of character ['@']. formatted input interpretation of character ['@'].
Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to Example: [printf "@[%s@ %d@]@." "x =" 1] is equivalent to
[open_box (); print_string "x ="; print_space (); [open_box (); print_string "x ="; print_space ();
print_int 1; close_box (); print_newline ()]. print_int 1; close_box (); print_newline ()].
It prints [x = 1] within a pretty-printing 'horizontal-or-vertical' box. It prints [x = 1] within a pretty-printing 'horizontal-or-vertical' box.
*) *)
val sprintf : ('a, unit, string) format -> 'a val sprintf : ('a, unit, string) format -> 'a
(** Same as [printf] above, but instead of printing on a formatter, (** Same as [printf] above, but instead of printing on a formatter,
returns a string containing the result of formatting the arguments. returns a string containing the result of formatting the arguments.
Note that the pretty-printer queue is flushed at the end of {e each Note that the pretty-printer queue is flushed at the end of {e each
call} to [sprintf]. call} to [sprintf].
In case of multiple and related calls to [sprintf] to output In case of multiple and related calls to [sprintf] to output
material on a single string, you should consider using [fprintf] material on a single string, you should consider using [fprintf]
with the predefined formatter [str_formatter] and call with the predefined formatter [str_formatter] and call
[flush_str_formatter ()] to get the final result. [flush_str_formatter ()] to get the final result.
Alternatively, you can use [Format.fprintf] with a formatter writing to a Alternatively, you can use [Format.fprintf] with a formatter writing to a
buffer of your own: flushing the formatter and the buffer at the end of buffer of your own: flushing the formatter and the buffer at the end of
pretty-printing returns the desired string. pretty-printing returns the desired string.
*) *)
val asprintf : ('a, formatter, unit, string) format4 -> 'a val asprintf : ('a, formatter, unit, string) format4 -> 'a
(** Same as [printf] above, but instead of printing on a formatter, (** Same as [printf] above, but instead of printing on a formatter,
returns a string containing the result of formatting the arguments. returns a string containing the result of formatting the arguments.
The type of [asprintf] is general enough to interact nicely with [%a] The type of [asprintf] is general enough to interact nicely with [%a]
conversions. conversions.
@since 4.01.0 @since 4.01.0
*) *)
val ifprintf : formatter -> ('a, formatter, unit) format -> 'a val ifprintf : formatter -> ('a, formatter, unit) format -> 'a
(** Same as [fprintf] above, but does not print anything. (** Same as [fprintf] above, but does not print anything.
Useful to ignore some material when conditionally printing. Useful to ignore some material when conditionally printing.
@since 3.10.0 @since 3.10.0
*) *)
(** Formatted output functions with continuations. *) (** Formatted output functions with continuations. *)
@ -348,22 +348,22 @@ val kfprintf :
(formatter -> 'a) -> formatter -> (formatter -> 'a) -> formatter ->
('b, formatter, unit, 'a) format4 -> 'b ('b, formatter, unit, 'a) format4 -> 'b
(** Same as [fprintf] above, but instead of returning immediately, (** Same as [fprintf] above, but instead of returning immediately,
passes the formatter to its first argument at the end of printing. *) passes the formatter to its first argument at the end of printing. *)
val ikfprintf : val ikfprintf :
(formatter -> 'a) -> formatter -> (formatter -> 'a) -> formatter ->
('b, formatter, unit, 'a) format4 -> 'b ('b, formatter, unit, 'a) format4 -> 'b
(** Same as [kfprintf] above, but does not print anything. (** Same as [kfprintf] above, but does not print anything.
Useful to ignore some material when conditionally printing. Useful to ignore some material when conditionally printing.
@since 3.12.0 @since 3.12.0
*) *)
val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b val ksprintf : (string -> 'a) -> ('b, unit, string, 'a) format4 -> 'b
(** Same as [sprintf] above, but instead of returning the string, (** Same as [sprintf] above, but instead of returning the string,
passes it to the first argument. *) passes it to the first argument. *)
val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b val kasprintf : (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b
(** Same as [asprintf] above, but instead of returning the string, (** Same as [asprintf] above, but instead of returning the string,
passes it to the first argument. passes it to the first argument.
@since 4.03 @since 4.03
*) *)

View File

@ -22,16 +22,16 @@
(** 32-bit integers. (** 32-bit integers.
This module provides operations on the type [int32] This module provides operations on the type [int32]
of signed 32-bit integers. Unlike the built-in [int] type, of signed 32-bit integers. Unlike the built-in [int] type,
the type [int32] is guaranteed to be exactly 32-bit wide on all the type [int32] is guaranteed to be exactly 32-bit wide on all
platforms. All arithmetic operations over [int32] are taken platforms. All arithmetic operations over [int32] are taken
modulo 2{^32}. modulo 2{^32}.
Performance notice: values of type [int32] occupy more memory Performance notice: values of type [int32] occupy more memory
space than values of type [int], and arithmetic operations on space than values of type [int], and arithmetic operations on
[int32] are generally slower than those on [int]. Use [int32] [int32] are generally slower than those on [int]. Use [int32]
only when the application requires exact 32-bit arithmetic. *) only when the application requires exact 32-bit arithmetic. *)
val zero : int32 val zero : int32
(** The 32-bit integer 0. *) (** The 32-bit integer 0. *)
@ -56,14 +56,14 @@ external mul : int32 -> int32 -> int32 = "%int32_mul"
external div : int32 -> int32 -> int32 = "%int32_div" external div : int32 -> int32 -> int32 = "%int32_div"
(** Integer division. Raise [Division_by_zero] if the second (** Integer division. Raise [Division_by_zero] if the second
argument is zero. This division rounds the real quotient of argument is zero. This division rounds the real quotient of
its arguments towards zero, as specified for {!Pervasives.(/)}. *) its arguments towards zero, as specified for {!Pervasives.(/)}. *)
external rem : int32 -> int32 -> int32 = "%int32_mod" external rem : int32 -> int32 -> int32 = "%int32_mod"
(** Integer remainder. If [y] is not zero, the result (** Integer remainder. If [y] is not zero, the result
of [Int32.rem x y] satisfies the following property: of [Int32.rem x y] satisfies the following property:
[x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)]. [x = Int32.add (Int32.mul (Int32.div x y) y) (Int32.rem x y)].
If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *) If [y = 0], [Int32.rem x y] raises [Division_by_zero]. *)
val succ : int32 -> int32 val succ : int32 -> int32
(** Successor. [Int32.succ x] is [Int32.add x Int32.one]. *) (** Successor. [Int32.succ x] is [Int32.add x Int32.one]. *)
@ -95,19 +95,19 @@ val lognot : int32 -> int32
external shift_left : int32 -> int -> int32 = "%int32_lsl" external shift_left : int32 -> int -> int32 = "%int32_lsl"
(** [Int32.shift_left x y] shifts [x] to the left by [y] bits. (** [Int32.shift_left x y] shifts [x] to the left by [y] bits.
The result is unspecified if [y < 0] or [y >= 32]. *) The result is unspecified if [y < 0] or [y >= 32]. *)
external shift_right : int32 -> int -> int32 = "%int32_asr" external shift_right : int32 -> int -> int32 = "%int32_asr"
(** [Int32.shift_right x y] shifts [x] to the right by [y] bits. (** [Int32.shift_right x y] shifts [x] to the right by [y] bits.
This is an arithmetic shift: the sign bit of [x] is replicated This is an arithmetic shift: the sign bit of [x] is replicated
and inserted in the vacated bits. and inserted in the vacated bits.
The result is unspecified if [y < 0] or [y >= 32]. *) The result is unspecified if [y < 0] or [y >= 32]. *)
external shift_right_logical : int32 -> int -> int32 = "%int32_lsr" external shift_right_logical : int32 -> int -> int32 = "%int32_lsr"
(** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits. (** [Int32.shift_right_logical x y] shifts [x] to the right by [y] bits.
This is a logical shift: zeroes are inserted in the vacated bits This is a logical shift: zeroes are inserted in the vacated bits
regardless of the sign of [x]. regardless of the sign of [x].
The result is unspecified if [y < 0] or [y >= 32]. *) The result is unspecified if [y < 0] or [y >= 32]. *)
external of_int : int -> int32 = "%int32_of_int" external of_int : int -> int32 = "%int32_of_int"
(** Convert the given integer (type [int]) to a 32-bit integer (** Convert the given integer (type [int]) to a 32-bit integer
@ -115,51 +115,51 @@ external of_int : int -> int32 = "%int32_of_int"
external to_int : int32 -> int = "%int32_to_int" external to_int : int32 -> int = "%int32_to_int"
(** Convert the given 32-bit integer (type [int32]) to an (** Convert the given 32-bit integer (type [int32]) to an
integer (type [int]). On 32-bit platforms, the 32-bit integer integer (type [int]). On 32-bit platforms, the 32-bit integer
is taken modulo 2{^31}, i.e. the high-order bit is lost is taken modulo 2{^31}, i.e. the high-order bit is lost
during the conversion. On 64-bit platforms, the conversion during the conversion. On 64-bit platforms, the conversion
is exact. *) is exact. *)
external of_float : float -> int32 external of_float : float -> int32
= "caml_int32_of_float" "caml_int32_of_float_unboxed" = "caml_int32_of_float" "caml_int32_of_float_unboxed"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Convert the given floating-point number to a 32-bit integer, (** Convert the given floating-point number to a 32-bit integer,
discarding the fractional part (truncate towards 0). discarding the fractional part (truncate towards 0).
The result of the conversion is undefined if, after truncation, The result of the conversion is undefined if, after truncation,
the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *) the number is outside the range \[{!Int32.min_int}, {!Int32.max_int}\]. *)
external to_float : int32 -> float external to_float : int32 -> float
= "caml_int32_to_float" "caml_int32_to_float_unboxed" = "caml_int32_to_float" "caml_int32_to_float_unboxed"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Convert the given 32-bit integer to a floating-point number. *) (** Convert the given 32-bit integer to a floating-point number. *)
external of_string : string -> int32 = "caml_int32_of_string" external of_string : string -> int32 = "caml_int32_of_string"
(** Convert the given string to a 32-bit integer. (** Convert the given string to a 32-bit integer.
The string is read in decimal (by default) or in hexadecimal, The string is read in decimal (by default) or in hexadecimal,
octal or binary if the string begins with [0x], [0o] or [0b] octal or binary if the string begins with [0x], [0o] or [0b]
respectively. respectively.
Raise [Failure "int_of_string"] if the given string is not Raise [Failure "int_of_string"] if the given string is not
a valid representation of an integer, or if the integer represented a valid representation of an integer, or if the integer represented
exceeds the range of integers representable in type [int32]. *) exceeds the range of integers representable in type [int32]. *)
val to_string : int32 -> string val to_string : int32 -> string
(** Return the string representation of its argument, in signed decimal. *) (** Return the string representation of its argument, in signed decimal. *)
external bits_of_float : float -> int32 external bits_of_float : float -> int32
= "caml_int32_bits_of_float" "caml_int32_bits_of_float_unboxed" = "caml_int32_bits_of_float" "caml_int32_bits_of_float_unboxed"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Return the internal representation of the given float according (** Return the internal representation of the given float according
to the IEEE 754 floating-point 'single format' bit layout. to the IEEE 754 floating-point 'single format' bit layout.
Bit 31 of the result represents the sign of the float; Bit 31 of the result represents the sign of the float;
bits 30 to 23 represent the (biased) exponent; bits 22 to 0 bits 30 to 23 represent the (biased) exponent; bits 22 to 0
represent the mantissa. *) represent the mantissa. *)
external float_of_bits : int32 -> float external float_of_bits : int32 -> float
= "caml_int32_float_of_bits" "caml_int32_float_of_bits_unboxed" = "caml_int32_float_of_bits" "caml_int32_float_of_bits_unboxed"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Return the floating-point number whose internal representation, (** Return the floating-point number whose internal representation,
according to the IEEE 754 floating-point 'single format' bit layout, according to the IEEE 754 floating-point 'single format' bit layout,
is the given [int32]. *) is the given [int32]. *)
type t = int32 type t = int32
(** An alias for the type of 32-bit integers. *) (** An alias for the type of 32-bit integers. *)

View File

@ -21,16 +21,16 @@
*) *)
(** 64-bit integers. (** 64-bit integers.
This module provides operations on the type [int64] of This module provides operations on the type [int64] of
signed 64-bit integers. Unlike the built-in [int] type, signed 64-bit integers. Unlike the built-in [int] type,
the type [int64] is guaranteed to be exactly 64-bit wide on all the type [int64] is guaranteed to be exactly 64-bit wide on all
platforms. All arithmetic operations over [int64] are taken platforms. All arithmetic operations over [int64] are taken
modulo 2{^64} modulo 2{^64}
Performance notice: values of type [int64] occupy more memory Performance notice: values of type [int64] occupy more memory
space than values of type [int], and arithmetic operations on space than values of type [int], and arithmetic operations on
[int64] are generally slower than those on [int]. Use [int64] [int64] are generally slower than those on [int]. Use [int64]
only when the application requires exact 64-bit arithmetic. only when the application requires exact 64-bit arithmetic.
*) *)
val zero : int64 val zero : int64
@ -56,14 +56,14 @@ external mul : int64 -> int64 -> int64 = "%int64_mul"
external div : int64 -> int64 -> int64 = "%int64_div" external div : int64 -> int64 -> int64 = "%int64_div"
(** Integer division. Raise [Division_by_zero] if the second (** Integer division. Raise [Division_by_zero] if the second
argument is zero. This division rounds the real quotient of argument is zero. This division rounds the real quotient of
its arguments towards zero, as specified for {!Pervasives.(/)}. *) its arguments towards zero, as specified for {!Pervasives.(/)}. *)
external rem : int64 -> int64 -> int64 = "%int64_mod" external rem : int64 -> int64 -> int64 = "%int64_mod"
(** Integer remainder. If [y] is not zero, the result (** Integer remainder. If [y] is not zero, the result
of [Int64.rem x y] satisfies the following property: of [Int64.rem x y] satisfies the following property:
[x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)]. [x = Int64.add (Int64.mul (Int64.div x y) y) (Int64.rem x y)].
If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *) If [y = 0], [Int64.rem x y] raises [Division_by_zero]. *)
val succ : int64 -> int64 val succ : int64 -> int64
(** Successor. [Int64.succ x] is [Int64.add x Int64.one]. *) (** Successor. [Int64.succ x] is [Int64.add x Int64.one]. *)
@ -94,19 +94,19 @@ val lognot : int64 -> int64
external shift_left : int64 -> int -> int64 = "%int64_lsl" external shift_left : int64 -> int -> int64 = "%int64_lsl"
(** [Int64.shift_left x y] shifts [x] to the left by [y] bits. (** [Int64.shift_left x y] shifts [x] to the left by [y] bits.
The result is unspecified if [y < 0] or [y >= 64]. *) The result is unspecified if [y < 0] or [y >= 64]. *)
external shift_right : int64 -> int -> int64 = "%int64_asr" external shift_right : int64 -> int -> int64 = "%int64_asr"
(** [Int64.shift_right x y] shifts [x] to the right by [y] bits. (** [Int64.shift_right x y] shifts [x] to the right by [y] bits.
This is an arithmetic shift: the sign bit of [x] is replicated This is an arithmetic shift: the sign bit of [x] is replicated
and inserted in the vacated bits. and inserted in the vacated bits.
The result is unspecified if [y < 0] or [y >= 64]. *) The result is unspecified if [y < 0] or [y >= 64]. *)
external shift_right_logical : int64 -> int -> int64 = "%int64_lsr" external shift_right_logical : int64 -> int -> int64 = "%int64_lsr"
(** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits. (** [Int64.shift_right_logical x y] shifts [x] to the right by [y] bits.
This is a logical shift: zeroes are inserted in the vacated bits This is a logical shift: zeroes are inserted in the vacated bits
regardless of the sign of [x]. regardless of the sign of [x].
The result is unspecified if [y < 0] or [y >= 64]. *) The result is unspecified if [y < 0] or [y >= 64]. *)
external of_int : int -> int64 = "%int64_of_int" external of_int : int -> int64 = "%int64_of_int"
(** Convert the given integer (type [int]) to a 64-bit integer (** Convert the given integer (type [int]) to a 64-bit integer
@ -114,73 +114,73 @@ external of_int : int -> int64 = "%int64_of_int"
external to_int : int64 -> int = "%int64_to_int" external to_int : int64 -> int = "%int64_to_int"
(** Convert the given 64-bit integer (type [int64]) to an (** Convert the given 64-bit integer (type [int64]) to an
integer (type [int]). On 64-bit platforms, the 64-bit integer integer (type [int]). On 64-bit platforms, the 64-bit integer
is taken modulo 2{^63}, i.e. the high-order bit is lost is taken modulo 2{^63}, i.e. the high-order bit is lost
during the conversion. On 32-bit platforms, the 64-bit integer during the conversion. On 32-bit platforms, the 64-bit integer
is taken modulo 2{^31}, i.e. the top 33 bits are lost is taken modulo 2{^31}, i.e. the top 33 bits are lost
during the conversion. *) during the conversion. *)
external of_float : float -> int64 external of_float : float -> int64
= "caml_int64_of_float" "caml_int64_of_float_unboxed" = "caml_int64_of_float" "caml_int64_of_float_unboxed"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Convert the given floating-point number to a 64-bit integer, (** Convert the given floating-point number to a 64-bit integer,
discarding the fractional part (truncate towards 0). discarding the fractional part (truncate towards 0).
The result of the conversion is undefined if, after truncation, The result of the conversion is undefined if, after truncation,
the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *) the number is outside the range \[{!Int64.min_int}, {!Int64.max_int}\]. *)
external to_float : int64 -> float external to_float : int64 -> float
= "caml_int64_to_float" "caml_int64_to_float_unboxed" = "caml_int64_to_float" "caml_int64_to_float_unboxed"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Convert the given 64-bit integer to a floating-point number. *) (** Convert the given 64-bit integer to a floating-point number. *)
external of_int32 : int32 -> int64 = "%int64_of_int32" external of_int32 : int32 -> int64 = "%int64_of_int32"
(** Convert the given 32-bit integer (type [int32]) (** Convert the given 32-bit integer (type [int32])
to a 64-bit integer (type [int64]). *) to a 64-bit integer (type [int64]). *)
external to_int32 : int64 -> int32 = "%int64_to_int32" external to_int32 : int64 -> int32 = "%int64_to_int32"
(** Convert the given 64-bit integer (type [int64]) to a (** Convert the given 64-bit integer (type [int64]) to a
32-bit integer (type [int32]). The 64-bit integer 32-bit integer (type [int32]). The 64-bit integer
is taken modulo 2{^32}, i.e. the top 32 bits are lost is taken modulo 2{^32}, i.e. the top 32 bits are lost
during the conversion. *) during the conversion. *)
external of_nativeint : nativeint -> int64 = "%int64_of_nativeint" external of_nativeint : nativeint -> int64 = "%int64_of_nativeint"
(** Convert the given native integer (type [nativeint]) (** Convert the given native integer (type [nativeint])
to a 64-bit integer (type [int64]). *) to a 64-bit integer (type [int64]). *)
external to_nativeint : int64 -> nativeint = "%int64_to_nativeint" external to_nativeint : int64 -> nativeint = "%int64_to_nativeint"
(** Convert the given 64-bit integer (type [int64]) to a (** Convert the given 64-bit integer (type [int64]) to a
native integer. On 32-bit platforms, the 64-bit integer native integer. On 32-bit platforms, the 64-bit integer
is taken modulo 2{^32}. On 64-bit platforms, is taken modulo 2{^32}. On 64-bit platforms,
the conversion is exact. *) the conversion is exact. *)
external of_string : string -> int64 = "caml_int64_of_string" external of_string : string -> int64 = "caml_int64_of_string"
(** Convert the given string to a 64-bit integer. (** Convert the given string to a 64-bit integer.
The string is read in decimal (by default) or in hexadecimal, The string is read in decimal (by default) or in hexadecimal,
octal or binary if the string begins with [0x], [0o] or [0b] octal or binary if the string begins with [0x], [0o] or [0b]
respectively. respectively.
Raise [Failure "int_of_string"] if the given string is not Raise [Failure "int_of_string"] if the given string is not
a valid representation of an integer, or if the integer represented a valid representation of an integer, or if the integer represented
exceeds the range of integers representable in type [int64]. *) exceeds the range of integers representable in type [int64]. *)
val to_string : int64 -> string val to_string : int64 -> string
(** Return the string representation of its argument, in decimal. *) (** Return the string representation of its argument, in decimal. *)
external bits_of_float : float -> int64 external bits_of_float : float -> int64
= "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed" = "caml_int64_bits_of_float" "caml_int64_bits_of_float_unboxed"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Return the internal representation of the given float according (** Return the internal representation of the given float according
to the IEEE 754 floating-point 'double format' bit layout. to the IEEE 754 floating-point 'double format' bit layout.
Bit 63 of the result represents the sign of the float; Bit 63 of the result represents the sign of the float;
bits 62 to 52 represent the (biased) exponent; bits 51 to 0 bits 62 to 52 represent the (biased) exponent; bits 51 to 0
represent the mantissa. *) represent the mantissa. *)
external float_of_bits : int64 -> float external float_of_bits : int64 -> float
= "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed" = "caml_int64_float_of_bits" "caml_int64_float_of_bits_unboxed"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Return the floating-point number whose internal representation, (** Return the floating-point number whose internal representation,
according to the IEEE 754 floating-point 'double format' bit layout, according to the IEEE 754 floating-point 'double format' bit layout,
is the given [int64]. *) is the given [int64]. *)
type t = int64 type t = int64
(** An alias for the type of 64-bit integers. *) (** An alias for the type of 64-bit integers. *)

View File

@ -15,15 +15,15 @@
(** List operations. (** List operations.
Some functions are flagged as not tail-recursive. A tail-recursive Some functions are flagged as not tail-recursive. A tail-recursive
function uses constant stack space, while a non-tail-recursive function function uses constant stack space, while a non-tail-recursive function
uses stack space proportional to the length of its list argument, which uses stack space proportional to the length of its list argument, which
can be a problem with very long lists. When the function takes several can be a problem with very long lists. When the function takes several
list arguments, an approximate formula giving stack usage (in some list arguments, an approximate formula giving stack usage (in some
unspecified constant unit) is shown in parentheses. unspecified constant unit) is shown in parentheses.
The above considerations can usually be ignored if your lists are not The above considerations can usually be ignored if your lists are not
longer than about 10000 elements. longer than about 10000 elements.
*) *)
val length : 'a list -> int val length : 'a list -> int
@ -36,35 +36,35 @@ val cons : 'a -> 'a list -> 'a list
val hd : 'a list -> 'a val hd : 'a list -> 'a
(** Return the first element of the given list. Raise (** Return the first element of the given list. Raise
[Failure "hd"] if the list is empty. *) [Failure "hd"] if the list is empty. *)
val tl : 'a list -> 'a list val tl : 'a list -> 'a list
(** Return the given list without its first element. Raise (** Return the given list without its first element. Raise
[Failure "tl"] if the list is empty. *) [Failure "tl"] if the list is empty. *)
val nth : 'a list -> int -> 'a val nth : 'a list -> int -> 'a
(** Return the [n]-th element of the given list. (** Return the [n]-th element of the given list.
The first element (head of the list) is at position 0. The first element (head of the list) is at position 0.
Raise [Failure "nth"] if the list is too short. Raise [Failure "nth"] if the list is too short.
Raise [Invalid_argument "List.nth"] if [n] is negative. *) Raise [Invalid_argument "List.nth"] if [n] is negative. *)
val rev : 'a list -> 'a list val rev : 'a list -> 'a list
(** List reversal. *) (** List reversal. *)
val append : 'a list -> 'a list -> 'a list val append : 'a list -> 'a list -> 'a list
(** Concatenate two lists. Same as the infix operator [@]. (** Concatenate two lists. Same as the infix operator [@].
Not tail-recursive (length of the first argument). *) Not tail-recursive (length of the first argument). *)
val rev_append : 'a list -> 'a list -> 'a list val rev_append : 'a list -> 'a list -> 'a list
(** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2]. (** [List.rev_append l1 l2] reverses [l1] and concatenates it to [l2].
This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is This is equivalent to {!List.rev}[ l1 @ l2], but [rev_append] is
tail-recursive and more efficient. *) tail-recursive and more efficient. *)
val concat : 'a list list -> 'a list val concat : 'a list list -> 'a list
(** Concatenate a list of lists. The elements of the argument are all (** Concatenate a list of lists. The elements of the argument are all
concatenated together (in the same order) to give the result. concatenated together (in the same order) to give the result.
Not tail-recursive Not tail-recursive
(length of the argument + length of the longest sub-list). *) (length of the argument + length of the longest sub-list). *)
val flatten : 'a list list -> 'a list val flatten : 'a list list -> 'a list
(** An alias for [concat]. *) (** An alias for [concat]. *)
@ -75,40 +75,40 @@ val flatten : 'a list list -> 'a list
val iter : ('a -> unit) -> 'a list -> unit val iter : ('a -> unit) -> 'a list -> unit
(** [List.iter f [a1; ...; an]] applies function [f] in turn to (** [List.iter f [a1; ...; an]] applies function [f] in turn to
[a1; ...; an]. It is equivalent to [a1; ...; an]. It is equivalent to
[begin f a1; f a2; ...; f an; () end]. *) [begin f a1; f a2; ...; f an; () end]. *)
val iteri : (int -> 'a -> unit) -> 'a list -> unit val iteri : (int -> 'a -> unit) -> 'a list -> unit
(** Same as {!List.iter}, but the function is applied to the index of (** Same as {!List.iter}, but the function is applied to the index of
the element as first argument (counting from 0), and the element the element as first argument (counting from 0), and the element
itself as second argument. itself as second argument.
@since 4.00.0 @since 4.00.0
*) *)
val map : ('a -> 'b) -> 'a list -> 'b list val map : ('a -> 'b) -> 'a list -> 'b list
(** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an],
and builds the list [[f a1; ...; f an]] and builds the list [[f a1; ...; f an]]
with the results returned by [f]. Not tail-recursive. *) with the results returned by [f]. Not tail-recursive. *)
val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list
(** Same as {!List.map}, but the function is applied to the index of (** Same as {!List.map}, but the function is applied to the index of
the element as first argument (counting from 0), and the element the element as first argument (counting from 0), and the element
itself as second argument. Not tail-recursive. itself as second argument. Not tail-recursive.
@since 4.00.0 @since 4.00.0
*) *)
val rev_map : ('a -> 'b) -> 'a list -> 'b list val rev_map : ('a -> 'b) -> 'a list -> 'b list
(** [List.rev_map f l] gives the same result as (** [List.rev_map f l] gives the same result as
{!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and
more efficient. *) more efficient. *)
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
(** [List.fold_left f a [b1; ...; bn]] is (** [List.fold_left f a [b1; ...; bn]] is
[f (... (f (f a b1) b2) ...) bn]. *) [f (... (f (f a b1) b2) ...) bn]. *)
val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
(** [List.fold_right f [a1; ...; an] b] is (** [List.fold_right f [a1; ...; an] b] is
[f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *) [f a1 (f a2 (... (f an b) ...))]. Not tail-recursive. *)
(** {6 Iterators on two lists} *) (** {6 Iterators on two lists} *)
@ -116,32 +116,32 @@ val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
(** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn (** [List.iter2 f [a1; ...; an] [b1; ...; bn]] calls in turn
[f a1 b1; ...; f an bn]. [f a1 b1; ...; f an bn].
Raise [Invalid_argument] if the two lists are determined Raise [Invalid_argument] if the two lists are determined
to have different lengths. *) to have different lengths. *)
val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(** [List.map2 f [a1; ...; an] [b1; ...; bn]] is (** [List.map2 f [a1; ...; an] [b1; ...; bn]] is
[[f a1 b1; ...; f an bn]]. [[f a1 b1; ...; f an bn]].
Raise [Invalid_argument] if the two lists are determined Raise [Invalid_argument] if the two lists are determined
to have different lengths. Not tail-recursive. *) to have different lengths. Not tail-recursive. *)
val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list val rev_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(** [List.rev_map2 f l1 l2] gives the same result as (** [List.rev_map2 f l1 l2] gives the same result as
{!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and {!List.rev}[ (]{!List.map2}[ f l1 l2)], but is tail-recursive and
more efficient. *) more efficient. *)
val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
(** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is (** [List.fold_left2 f a [b1; ...; bn] [c1; ...; cn]] is
[f (... (f (f a b1 c1) b2 c2) ...) bn cn]. [f (... (f (f a b1 c1) b2 c2) ...) bn cn].
Raise [Invalid_argument] if the two lists are determined Raise [Invalid_argument] if the two lists are determined
to have different lengths. *) to have different lengths. *)
val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
(** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is (** [List.fold_right2 f [a1; ...; an] [b1; ...; bn] c] is
[f a1 b1 (f a2 b2 (... (f an bn c) ...))]. [f a1 b1 (f a2 b2 (... (f an bn c) ...))].
Raise [Invalid_argument] if the two lists are determined Raise [Invalid_argument] if the two lists are determined
to have different lengths. Not tail-recursive. *) to have different lengths. Not tail-recursive. *)
(** {6 List scanning} *) (** {6 List scanning} *)
@ -149,31 +149,31 @@ val fold_right2 : ('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
val for_all : ('a -> bool) -> 'a list -> bool val for_all : ('a -> bool) -> 'a list -> bool
(** [for_all p [a1; ...; an]] checks if all elements of the list (** [for_all p [a1; ...; an]] checks if all elements of the list
satisfy the predicate [p]. That is, it returns satisfy the predicate [p]. That is, it returns
[(p a1) && (p a2) && ... && (p an)]. *) [(p a1) && (p a2) && ... && (p an)]. *)
val exists : ('a -> bool) -> 'a list -> bool val exists : ('a -> bool) -> 'a list -> bool
(** [exists p [a1; ...; an]] checks if at least one element of (** [exists p [a1; ...; an]] checks if at least one element of
the list satisfies the predicate [p]. That is, it returns the list satisfies the predicate [p]. That is, it returns
[(p a1) || (p a2) || ... || (p an)]. *) [(p a1) || (p a2) || ... || (p an)]. *)
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
(** Same as {!List.for_all}, but for a two-argument predicate. (** Same as {!List.for_all}, but for a two-argument predicate.
Raise [Invalid_argument] if the two lists are determined Raise [Invalid_argument] if the two lists are determined
to have different lengths. *) to have different lengths. *)
val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool val exists2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
(** Same as {!List.exists}, but for a two-argument predicate. (** Same as {!List.exists}, but for a two-argument predicate.
Raise [Invalid_argument] if the two lists are determined Raise [Invalid_argument] if the two lists are determined
to have different lengths. *) to have different lengths. *)
val mem : 'a -> 'a list -> bool val mem : 'a -> 'a list -> bool
(** [mem a l] is true if and only if [a] is equal (** [mem a l] is true if and only if [a] is equal
to an element of [l]. *) to an element of [l]. *)
val memq : 'a -> 'a list -> bool val memq : 'a -> 'a list -> bool
(** Same as {!List.mem}, but uses physical equality instead of structural (** Same as {!List.mem}, but uses physical equality instead of structural
equality to compare list elements. *) equality to compare list elements. *)
(** {6 List searching} *) (** {6 List searching} *)
@ -181,24 +181,24 @@ val memq : 'a -> 'a list -> bool
val find : ('a -> bool) -> 'a list -> 'a val find : ('a -> bool) -> 'a list -> 'a
(** [find p l] returns the first element of the list [l] (** [find p l] returns the first element of the list [l]
that satisfies the predicate [p]. that satisfies the predicate [p].
Raise [Not_found] if there is no value that satisfies [p] in the Raise [Not_found] if there is no value that satisfies [p] in the
list [l]. *) list [l]. *)
val filter : ('a -> bool) -> 'a list -> 'a list val filter : ('a -> bool) -> 'a list -> 'a list
(** [filter p l] returns all the elements of the list [l] (** [filter p l] returns all the elements of the list [l]
that satisfy the predicate [p]. The order of the elements that satisfy the predicate [p]. The order of the elements
in the input list is preserved. *) in the input list is preserved. *)
val find_all : ('a -> bool) -> 'a list -> 'a list val find_all : ('a -> bool) -> 'a list -> 'a list
(** [find_all] is another name for {!List.filter}. *) (** [find_all] is another name for {!List.filter}. *)
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
(** [partition p l] returns a pair of lists [(l1, l2)], where (** [partition p l] returns a pair of lists [(l1, l2)], where
[l1] is the list of all the elements of [l] that [l1] is the list of all the elements of [l] that
satisfy the predicate [p], and [l2] is the list of all the satisfy the predicate [p], and [l2] is the list of all the
elements of [l] that do not satisfy [p]. elements of [l] that do not satisfy [p].
The order of the elements in the input list is preserved. *) The order of the elements in the input list is preserved. *)
(** {6 Association lists} *) (** {6 Association lists} *)
@ -206,32 +206,32 @@ val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
val assoc : 'a -> ('a * 'b) list -> 'b val assoc : 'a -> ('a * 'b) list -> 'b
(** [assoc a l] returns the value associated with key [a] in the list of (** [assoc a l] returns the value associated with key [a] in the list of
pairs [l]. That is, pairs [l]. That is,
[assoc a [ ...; (a,b); ...] = b] [assoc a [ ...; (a,b); ...] = b]
if [(a,b)] is the leftmost binding of [a] in list [l]. if [(a,b)] is the leftmost binding of [a] in list [l].
Raise [Not_found] if there is no value associated with [a] in the Raise [Not_found] if there is no value associated with [a] in the
list [l]. *) list [l]. *)
val assq : 'a -> ('a * 'b) list -> 'b val assq : 'a -> ('a * 'b) list -> 'b
(** Same as {!List.assoc}, but uses physical equality instead of structural (** Same as {!List.assoc}, but uses physical equality instead of structural
equality to compare keys. *) equality to compare keys. *)
val mem_assoc : 'a -> ('a * 'b) list -> bool val mem_assoc : 'a -> ('a * 'b) list -> bool
(** Same as {!List.assoc}, but simply return true if a binding exists, (** Same as {!List.assoc}, but simply return true if a binding exists,
and false if no bindings exist for the given key. *) and false if no bindings exist for the given key. *)
val mem_assq : 'a -> ('a * 'b) list -> bool val mem_assq : 'a -> ('a * 'b) list -> bool
(** Same as {!List.mem_assoc}, but uses physical equality instead of (** Same as {!List.mem_assoc}, but uses physical equality instead of
structural equality to compare keys. *) structural equality to compare keys. *)
val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list val remove_assoc : 'a -> ('a * 'b) list -> ('a * 'b) list
(** [remove_assoc a l] returns the list of (** [remove_assoc a l] returns the list of
pairs [l] without the first pair with key [a], if any. pairs [l] without the first pair with key [a], if any.
Not tail-recursive. *) Not tail-recursive. *)
val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
(** Same as {!List.remove_assoc}, but uses physical equality instead (** Same as {!List.remove_assoc}, but uses physical equality instead
of structural equality to compare keys. Not tail-recursive. *) of structural equality to compare keys. Not tail-recursive. *)
(** {6 Lists of pairs} *) (** {6 Lists of pairs} *)
@ -239,16 +239,16 @@ val remove_assq : 'a -> ('a * 'b) list -> ('a * 'b) list
val split : ('a * 'b) list -> 'a list * 'b list val split : ('a * 'b) list -> 'a list * 'b list
(** Transform a list of pairs into a pair of lists: (** Transform a list of pairs into a pair of lists:
[split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])]. [split [(a1,b1); ...; (an,bn)]] is [([a1; ...; an], [b1; ...; bn])].
Not tail-recursive. Not tail-recursive.
*) *)
val combine : 'a list -> 'b list -> ('a * 'b) list val combine : 'a list -> 'b list -> ('a * 'b) list
(** Transform a pair of lists into a list of pairs: (** Transform a pair of lists into a list of pairs:
[combine [a1; ...; an] [b1; ...; bn]] is [combine [a1; ...; an] [b1; ...; bn]] is
[[(a1,b1); ...; (an,bn)]]. [[(a1,b1); ...; (an,bn)]].
Raise [Invalid_argument] if the two lists Raise [Invalid_argument] if the two lists
have different lengths. Not tail-recursive. *) have different lengths. Not tail-recursive. *)
(** {6 Sorting} *) (** {6 Sorting} *)
@ -256,27 +256,27 @@ val combine : 'a list -> 'b list -> ('a * 'b) list
val sort : ('a -> 'a -> int) -> 'a list -> 'a list val sort : ('a -> 'a -> int) -> 'a list -> 'a list
(** Sort a list in increasing order according to a comparison (** Sort a list in increasing order according to a comparison
function. The comparison function must return 0 if its arguments function. The comparison function must return 0 if its arguments
compare as equal, a positive integer if the first is greater, compare as equal, a positive integer if the first is greater,
and a negative integer if the first is smaller (see Array.sort for and a negative integer if the first is smaller (see Array.sort for
a complete specification). For example, a complete specification). For example,
{!Pervasives.compare} is a suitable comparison function. {!Pervasives.compare} is a suitable comparison function.
The resulting list is sorted in increasing order. The resulting list is sorted in increasing order.
[List.sort] is guaranteed to run in constant heap space [List.sort] is guaranteed to run in constant heap space
(in addition to the size of the result list) and logarithmic (in addition to the size of the result list) and logarithmic
stack space. stack space.
The current implementation uses Merge Sort. It runs in constant The current implementation uses Merge Sort. It runs in constant
heap space and logarithmic stack space. heap space and logarithmic stack space.
*) *)
val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
(** Same as {!List.sort}, but the sorting algorithm is guaranteed to (** Same as {!List.sort}, but the sorting algorithm is guaranteed to
be stable (i.e. elements that compare equal are kept in their be stable (i.e. elements that compare equal are kept in their
original order) . original order) .
The current implementation uses Merge Sort. It runs in constant The current implementation uses Merge Sort. It runs in constant
heap space and logarithmic stack space. heap space and logarithmic stack space.
*) *)
val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list val fast_sort : ('a -> 'a -> int) -> 'a list -> 'a list

View File

@ -20,7 +20,7 @@
* License along with this program; if not, write to the Free Software * License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA. * 02111-1307, USA.
*) *)
(* TEZOS CHANGES (* TEZOS CHANGES
@ -62,63 +62,63 @@
(** {2 Definitions and basics} *) (** {2 Definitions and basics} *)
type +'a t type +'a t
(** The type of threads returning a result of type ['a]. *) (** The type of threads returning a result of type ['a]. *)
val return : 'a -> 'a t val return : 'a -> 'a t
(** [return e] is a thread whose return value is the value of the (** [return e] is a thread whose return value is the value of the
expression [e]. *) expression [e]. *)
(* val fail : exn -> 'a t *) (* val fail : exn -> 'a t *)
(* (\** [fail e] is a thread that fails with the exception [e]. *\) *) (* (\** [fail e] is a thread that fails with the exception [e]. *\) *)
val bind : 'a t -> ('a -> 'b t) -> 'b t val bind : 'a t -> ('a -> 'b t) -> 'b t
(** [bind t f] is a thread which first waits for the thread [t] to (** [bind t f] is a thread which first waits for the thread [t] to
terminate and then, if the thread succeeds, behaves as the terminate and then, if the thread succeeds, behaves as the
application of function [f] to the return value of [t]. If the application of function [f] to the return value of [t]. If the
thread [t] fails, [bind t f] also fails, with the same thread [t] fails, [bind t f] also fails, with the same
exception. exception.
The expression [bind t (fun x -> t')] can intuitively be read as The expression [bind t (fun x -> t')] can intuitively be read as
[let x = t in t'], and if you use the {e lwt.syntax} syntax [let x = t in t'], and if you use the {e lwt.syntax} syntax
extension, you can write a bind operation like that: [lwt x = t in t']. extension, you can write a bind operation like that: [lwt x = t in t'].
Note that [bind] is also often used just for synchronization Note that [bind] is also often used just for synchronization
purpose: [t'] will not execute before [t] is terminated. purpose: [t'] will not execute before [t] is terminated.
The result of a thread can be bound several time. *) The result of a thread can be bound several time. *)
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
(** [t >>= f] is an alternative notation for [bind t f]. *) (** [t >>= f] is an alternative notation for [bind t f]. *)
val (=<<) : ('a -> 'b t) -> 'a t -> 'b t val (=<<) : ('a -> 'b t) -> 'a t -> 'b t
(** [f =<< t] is [t >>= f] *) (** [f =<< t] is [t >>= f] *)
val map : ('a -> 'b) -> 'a t -> 'b t val map : ('a -> 'b) -> 'a t -> 'b t
(** [map f m] map the result of a thread. This is the same as [bind (** [map f m] map the result of a thread. This is the same as [bind
m (fun x -> return (f x))] *) m (fun x -> return (f x))] *)
val (>|=) : 'a t -> ('a -> 'b) -> 'b t val (>|=) : 'a t -> ('a -> 'b) -> 'b t
(** [m >|= f] is [map f m] *) (** [m >|= f] is [map f m] *)
val (=|<) : ('a -> 'b) -> 'a t -> 'b t val (=|<) : ('a -> 'b) -> 'a t -> 'b t
(** [f =|< m] is [map f m] *) (** [f =|< m] is [map f m] *)
(** {3 Pre-allocated threads} *) (** {3 Pre-allocated threads} *)
val return_unit : unit t val return_unit : unit t
(** [return_unit = return ()] *) (** [return_unit = return ()] *)
val return_none : 'a option t val return_none : 'a option t
(** [return_none = return None] *) (** [return_none = return None] *)
val return_nil : 'a list t val return_nil : 'a list t
(** [return_nil = return \[\]] *) (** [return_nil = return \[\]] *)
val return_true : bool t val return_true : bool t
(** [return_true = return true] *) (** [return_true = return true] *)
val return_false : bool t val return_false : bool t
(** [return_false = return false] *) (** [return_false = return false] *)
(* (\** {2 Thread storage} *\) *) (* (\** {2 Thread storage} *\) *)
@ -223,18 +223,18 @@ val return_false : bool t
(* the list of threads that have not yet terminated. *\) *) (* the list of threads that have not yet terminated. *\) *)
val join : unit t list -> unit t val join : unit t list -> unit t
(** [join l] waits for all threads in [l] to terminate. If one of (** [join l] waits for all threads in [l] to terminate. If one of
the threads fails, then [join l] will fails with the same the threads fails, then [join l] will fails with the same
exception as the first one to terminate. exception as the first one to terminate.
Note: {!join} leaves the local values of the current thread Note: {!join} leaves the local values of the current thread
unchanged. *) unchanged. *)
(* val ( <?> ) : 'a t -> 'a t -> 'a t *) (* val ( <?> ) : 'a t -> 'a t -> 'a t *)
(* (\** [t <?> t'] is the same as [choose [t; t']] *\) *) (* (\** [t <?> t'] is the same as [choose [t; t']] *\) *)
val ( <&> ) : unit t -> unit t -> unit t val ( <&> ) : unit t -> unit t -> unit t
(** [t <&> t'] is the same as [join [t; t']] *) (** [t <&> t'] is the same as [join [t; t']] *)
(* val async : (unit -> 'a t) -> unit *) (* val async : (unit -> 'a t) -> unit *)
(* (\** [async f] starts a thread without waiting for the result. If it *) (* (\** [async f] starts a thread without waiting for the result. If it *)

View File

@ -18,7 +18,7 @@
* License along with this program; if not, write to the Free Software * License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA. * 02111-1307, USA.
*) *)
(** List helpers *) (** List helpers *)

View File

@ -18,7 +18,7 @@
* License along with this program; if not, write to the Free Software * License along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
* 02111-1307, USA. * 02111-1307, USA.
*) *)
(** Mutable sequence of elements *) (** Mutable sequence of elements *)
@ -32,124 +32,124 @@
*) *)
type 'a t type 'a t
(** Type of a sequence holding values of type ['a] *) (** Type of a sequence holding values of type ['a] *)
type 'a node type 'a node
(** Type of a node holding one value of type ['a] in a sequence *) (** Type of a node holding one value of type ['a] in a sequence *)
(** {2 Operation on nodes} *) (** {2 Operation on nodes} *)
val get : 'a node -> 'a val get : 'a node -> 'a
(** Returns the contents of a node *) (** Returns the contents of a node *)
val set : 'a node -> 'a -> unit val set : 'a node -> 'a -> unit
(** Change the contents of a node *) (** Change the contents of a node *)
val remove : 'a node -> unit val remove : 'a node -> unit
(** Removes a node from the sequence it is part of. It does nothing (** Removes a node from the sequence it is part of. It does nothing
if the node has already been removed. *) if the node has already been removed. *)
(** {2 Operations on sequence} *) (** {2 Operations on sequence} *)
val create : unit -> 'a t val create : unit -> 'a t
(** [create ()] creates a new empty sequence *) (** [create ()] creates a new empty sequence *)
val is_empty : 'a t -> bool val is_empty : 'a t -> bool
(** Returns [true] iff the given sequence is empty *) (** Returns [true] iff the given sequence is empty *)
val length : 'a t -> int val length : 'a t -> int
(** Returns the number of elemenets in the given sequence. This is a (** Returns the number of elemenets in the given sequence. This is a
O(n) operation where [n] is the number of elements in the O(n) operation where [n] is the number of elements in the
sequence. *) sequence. *)
val add_l : 'a -> 'a t -> 'a node val add_l : 'a -> 'a t -> 'a node
(** [add_l x s] adds [x] to the left of the sequence [s] *) (** [add_l x s] adds [x] to the left of the sequence [s] *)
val add_r : 'a -> 'a t -> 'a node val add_r : 'a -> 'a t -> 'a node
(** [add_l x s] adds [x] to the right of the sequence [s] *) (** [add_l x s] adds [x] to the right of the sequence [s] *)
exception Empty exception Empty
(** Exception raised by [take_l] and [tale_s] and when the sequence (** Exception raised by [take_l] and [tale_s] and when the sequence
is empty *) is empty *)
val take_l : 'a t -> 'a val take_l : 'a t -> 'a
(** [take_l x s] remove and returns the leftmost element of [s] (** [take_l x s] remove and returns the leftmost element of [s]
@raise Empty if the sequence is empty *) @raise Empty if the sequence is empty *)
val take_r : 'a t -> 'a val take_r : 'a t -> 'a
(** [take_l x s] remove and returns the rightmost element of [s] (** [take_l x s] remove and returns the rightmost element of [s]
@raise Empty if the sequence is empty *) @raise Empty if the sequence is empty *)
val take_opt_l : 'a t -> 'a option val take_opt_l : 'a t -> 'a option
(** [take_opt_l x s] remove and returns [Some x] where [x] is the (** [take_opt_l x s] remove and returns [Some x] where [x] is the
leftmost element of [s] or [None] if [s] is empty *) leftmost element of [s] or [None] if [s] is empty *)
val take_opt_r : 'a t -> 'a option val take_opt_r : 'a t -> 'a option
(** [take_opt_l x s] remove and returns [Some x] where [x] is the (** [take_opt_l x s] remove and returns [Some x] where [x] is the
rightmost element of [s] or [None] if [s] is empty *) rightmost element of [s] or [None] if [s] is empty *)
val transfer_l : 'a t -> 'a t -> unit val transfer_l : 'a t -> 'a t -> unit
(** [transfer_l s1 s2] removes all elements of [s1] and add them at (** [transfer_l s1 s2] removes all elements of [s1] and add them at
the left of [s2]. This operation runs in constant time and the left of [s2]. This operation runs in constant time and
space. *) space. *)
val transfer_r : 'a t -> 'a t -> unit val transfer_r : 'a t -> 'a t -> unit
(** [transfer_r s1 s2] removes all elements of [s1] and add them at (** [transfer_r s1 s2] removes all elements of [s1] and add them at
the right of [s2]. This operation runs in constant time and the right of [s2]. This operation runs in constant time and
space. *) space. *)
(** {2 Sequence iterators} *) (** {2 Sequence iterators} *)
(** Note: it is OK to remove a node while traversing a sequence *) (** Note: it is OK to remove a node while traversing a sequence *)
val iter_l : ('a -> unit) -> 'a t -> unit val iter_l : ('a -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all elements of [s] starting from (** [iter_l f s] applies [f] on all elements of [s] starting from
the left *) the left *)
val iter_r : ('a -> unit) -> 'a t -> unit val iter_r : ('a -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all elements of [s] starting from (** [iter_l f s] applies [f] on all elements of [s] starting from
the right *) the right *)
val iter_node_l : ('a node -> unit) -> 'a t -> unit val iter_node_l : ('a node -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all nodes of [s] starting from (** [iter_l f s] applies [f] on all nodes of [s] starting from
the left *) the left *)
val iter_node_r : ('a node -> unit) -> 'a t -> unit val iter_node_r : ('a node -> unit) -> 'a t -> unit
(** [iter_l f s] applies [f] on all nodes of [s] starting from (** [iter_l f s] applies [f] on all nodes of [s] starting from
the right *) the right *)
val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(** [fold_l f s] is: (** [fold_l f s] is:
{[ {[
fold_l f s x = f en (... (f e2 (f e1 x))) fold_l f s x = f en (... (f e2 (f e1 x)))
]} ]}
where [e1], [e2], ..., [en] are the elements of [s] where [e1], [e2], ..., [en] are the elements of [s]
*) *)
val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(** [fold_r f s] is: (** [fold_r f s] is:
{[ {[
fold_r f s x = f e1 (f e2 (... (f en x))) fold_r f s x = f e1 (f e2 (... (f en x)))
]} ]}
where [e1], [e2], ..., [en] are the elements of [s] where [e1], [e2], ..., [en] are the elements of [s]
*) *)
val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option val find_node_opt_l : ('a -> bool) -> 'a t -> 'a node option
(** [find_node_opt_l f s] returns [Some x], where [x] is the first node of (** [find_node_opt_l f s] returns [Some x], where [x] is the first node of
[s] starting from the left that satisfies [f] or [None] if none [s] starting from the left that satisfies [f] or [None] if none
exists. *) exists. *)
val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option val find_node_opt_r : ('a -> bool) -> 'a t -> 'a node option
(** [find_node_opt_r f s] returns [Some x], where [x] is the first node of (** [find_node_opt_r f s] returns [Some x], where [x] is the first node of
[s] starting from the right that satisfies [f] or [None] if none [s] starting from the right that satisfies [f] or [None] if none
exists. *) exists. *)
val find_node_l : ('a -> bool) -> 'a t -> 'a node val find_node_l : ('a -> bool) -> 'a t -> 'a node
(** [find_node_l f s] returns the first node of [s] starting from the left (** [find_node_l f s] returns the first node of [s] starting from the left
that satisfies [f] or raises [Not_found] if none exists. *) that satisfies [f] or raises [Not_found] if none exists. *)
val find_node_r : ('a -> bool) -> 'a t -> 'a node val find_node_r : ('a -> bool) -> 'a t -> 'a node
(** [find_node_r f s] returns the first node of [s] starting from the right (** [find_node_r f s] returns the first node of [s] starting from the right
that satisfies [f] or raises [Not_found] if none exists. *) that satisfies [f] or raises [Not_found] if none exists. *)

View File

@ -15,218 +15,218 @@
(** Association tables over ordered types. (** Association tables over ordered types.
This module implements applicative association tables, also known as This module implements applicative association tables, also known as
finite maps or dictionaries, given a total ordering function finite maps or dictionaries, given a total ordering function
over the keys. over the keys.
All operations over maps are purely applicative (no side-effects). All operations over maps are purely applicative (no side-effects).
The implementation uses balanced binary trees, and therefore searching The implementation uses balanced binary trees, and therefore searching
and insertion take time logarithmic in the size of the map. and insertion take time logarithmic in the size of the map.
For instance: For instance:
{[ {[
module IntPairs = module IntPairs =
struct struct
type t = int * int type t = int * int
let compare (x0,y0) (x1,y1) = let compare (x0,y0) (x1,y1) =
match Pervasives.compare x0 x1 with match Pervasives.compare x0 x1 with
0 -> Pervasives.compare y0 y1 0 -> Pervasives.compare y0 y1
| c -> c | c -> c
end end
module PairsMap = Map.Make(IntPairs) module PairsMap = Map.Make(IntPairs)
let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world") let m = PairsMap.(empty |> add (0,1) "hello" |> add (1,0) "world")
]} ]}
This creates a new module [PairsMap], with a new type ['a PairsMap.t] This creates a new module [PairsMap], with a new type ['a PairsMap.t]
of maps from [int * int] to ['a]. In this example, [m] contains [string] of maps from [int * int] to ['a]. In this example, [m] contains [string]
values so its type is [string PairsMap.t]. values so its type is [string PairsMap.t].
*) *)
module type OrderedType = module type OrderedType =
sig sig
type t type t
(** The type of the map keys. *) (** The type of the map keys. *)
val compare : t -> t -> int val compare : t -> t -> int
(** A total ordering function over the keys. (** A total ordering function over the keys.
This is a two-argument function [f] such that This is a two-argument function [f] such that
[f e1 e2] is zero if the keys [e1] and [e2] are equal, [f e1 e2] is zero if the keys [e1] and [e2] are equal,
[f e1 e2] is strictly negative if [e1] is smaller than [e2], [f e1 e2] is strictly negative if [e1] is smaller than [e2],
and [f e1 e2] is strictly positive if [e1] is greater than [e2]. and [f e1 e2] is strictly positive if [e1] is greater than [e2].
Example: a suitable ordering function is the generic structural Example: a suitable ordering function is the generic structural
comparison function {!Pervasives.compare}. *) comparison function {!Pervasives.compare}. *)
end end
(** Input signature of the functor {!Map.Make}. *) (** Input signature of the functor {!Map.Make}. *)
module type S = module type S =
sig sig
type key type key
(** The type of the map keys. *) (** The type of the map keys. *)
type (+'a) t type (+'a) t
(** The type of maps from type [key] to type ['a]. *) (** The type of maps from type [key] to type ['a]. *)
val empty: 'a t val empty: 'a t
(** The empty map. *) (** The empty map. *)
val is_empty: 'a t -> bool val is_empty: 'a t -> bool
(** Test whether a map is empty or not. *) (** Test whether a map is empty or not. *)
val mem: key -> 'a t -> bool val mem: key -> 'a t -> bool
(** [mem x m] returns [true] if [m] contains a binding for [x], (** [mem x m] returns [true] if [m] contains a binding for [x],
and [false] otherwise. *) and [false] otherwise. *)
val add: key -> 'a -> 'a t -> 'a t val add: key -> 'a -> 'a t -> 'a t
(** [add x y m] returns a map containing the same bindings as (** [add x y m] returns a map containing the same bindings as
[m], plus a binding of [x] to [y]. If [x] was already bound [m], plus a binding of [x] to [y]. If [x] was already bound
in [m] to a value that is physically equal to [y], in [m] to a value that is physically equal to [y],
[m] is returned unchanged (the result of the function is [m] is returned unchanged (the result of the function is
then physically equal to [m]). Otherwise, the previous binding then physically equal to [m]). Otherwise, the previous binding
of [x] in [m] disappears. of [x] in [m] disappears.
@before 4.03 Physical equality was not ensured. *) @before 4.03 Physical equality was not ensured. *)
val singleton: key -> 'a -> 'a t val singleton: key -> 'a -> 'a t
(** [singleton x y] returns the one-element map that contains a binding [y] (** [singleton x y] returns the one-element map that contains a binding [y]
for [x]. for [x].
@since 3.12.0 @since 3.12.0
*) *)
val remove: key -> 'a t -> 'a t val remove: key -> 'a t -> 'a t
(** [remove x m] returns a map containing the same bindings as (** [remove x m] returns a map containing the same bindings as
[m], except for [x] which is unbound in the returned map. [m], except for [x] which is unbound in the returned map.
If [x] was not in [m], [m] is returned unchanged If [x] was not in [m], [m] is returned unchanged
(the result of the function is then physically equal to [m]). (the result of the function is then physically equal to [m]).
@before 4.03 Physical equality was not ensured. *) @before 4.03 Physical equality was not ensured. *)
val merge: val merge:
(key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t (key -> 'a option -> 'b option -> 'c option) -> 'a t -> 'b t -> 'c t
(** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1] (** [merge f m1 m2] computes a map whose keys is a subset of keys of [m1]
and of [m2]. The presence of each such binding, and the corresponding and of [m2]. The presence of each such binding, and the corresponding
value, is determined with the function [f]. value, is determined with the function [f].
@since 3.12.0 @since 3.12.0
*) *)
val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t val union: (key -> 'a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
(** [union f m1 m2] computes a map whose keys is the union of keys (** [union f m1 m2] computes a map whose keys is the union of keys
of [m1] and of [m2]. When the same binding is defined in both of [m1] and of [m2]. When the same binding is defined in both
arguments, the function [f] is used to combine them. arguments, the function [f] is used to combine them.
@since 4.03.0 @since 4.03.0
*) *)
val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
(** Total ordering between maps. The first argument is a total ordering (** Total ordering between maps. The first argument is a total ordering
used to compare data associated with equal keys in the two maps. *) used to compare data associated with equal keys in the two maps. *)
val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
(** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are
equal, that is, contain equal keys and associate them with equal, that is, contain equal keys and associate them with
equal data. [cmp] is the equality predicate used to compare equal data. [cmp] is the equality predicate used to compare
the data associated with the keys. *) the data associated with the keys. *)
val iter: (key -> 'a -> unit) -> 'a t -> unit val iter: (key -> 'a -> unit) -> 'a t -> unit
(** [iter f m] applies [f] to all bindings in map [m]. (** [iter f m] applies [f] to all bindings in map [m].
[f] receives the key as first argument, and the associated value [f] receives the key as first argument, and the associated value
as second argument. The bindings are passed to [f] in increasing as second argument. The bindings are passed to [f] in increasing
order with respect to the ordering over the type of the keys. *) order with respect to the ordering over the type of the keys. *)
val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
(** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
where [k1 ... kN] are the keys of all bindings in [m] where [k1 ... kN] are the keys of all bindings in [m]
(in increasing order), and [d1 ... dN] are the associated data. *) (in increasing order), and [d1 ... dN] are the associated data. *)
val for_all: (key -> 'a -> bool) -> 'a t -> bool val for_all: (key -> 'a -> bool) -> 'a t -> bool
(** [for_all p m] checks if all the bindings of the map (** [for_all p m] checks if all the bindings of the map
satisfy the predicate [p]. satisfy the predicate [p].
@since 3.12.0 @since 3.12.0
*) *)
val exists: (key -> 'a -> bool) -> 'a t -> bool val exists: (key -> 'a -> bool) -> 'a t -> bool
(** [exists p m] checks if at least one binding of the map (** [exists p m] checks if at least one binding of the map
satisfy the predicate [p]. satisfy the predicate [p].
@since 3.12.0 @since 3.12.0
*) *)
val filter: (key -> 'a -> bool) -> 'a t -> 'a t val filter: (key -> 'a -> bool) -> 'a t -> 'a t
(** [filter p m] returns the map with all the bindings in [m] (** [filter p m] returns the map with all the bindings in [m]
that satisfy predicate [p]. If [p] satisfies every binding in [m], that satisfy predicate [p]. If [p] satisfies every binding in [m],
[m] is returned unchanged (the result of the function is then [m] is returned unchanged (the result of the function is then
physically equal to [m]) physically equal to [m])
@since 3.12.0 @since 3.12.0
@before 4.03 Physical equality was not ensured. @before 4.03 Physical equality was not ensured.
*) *)
val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t val partition: (key -> 'a -> bool) -> 'a t -> 'a t * 'a t
(** [partition p m] returns a pair of maps [(m1, m2)], where (** [partition p m] returns a pair of maps [(m1, m2)], where
[m1] contains all the bindings of [s] that satisfy the [m1] contains all the bindings of [s] that satisfy the
predicate [p], and [m2] is the map with all the bindings of predicate [p], and [m2] is the map with all the bindings of
[s] that do not satisfy [p]. [s] that do not satisfy [p].
@since 3.12.0 @since 3.12.0
*) *)
val cardinal: 'a t -> int val cardinal: 'a t -> int
(** Return the number of bindings of a map. (** Return the number of bindings of a map.
@since 3.12.0 @since 3.12.0
*) *)
val bindings: 'a t -> (key * 'a) list val bindings: 'a t -> (key * 'a) list
(** Return the list of all bindings of the given map. (** Return the list of all bindings of the given map.
The returned list is sorted in increasing order with respect The returned list is sorted in increasing order with respect
to the ordering [Ord.compare], where [Ord] is the argument to the ordering [Ord.compare], where [Ord] is the argument
given to {!Map.Make}. given to {!Map.Make}.
@since 3.12.0 @since 3.12.0
*) *)
val min_binding: 'a t -> (key * 'a) val min_binding: 'a t -> (key * 'a)
(** Return the smallest binding of the given map (** Return the smallest binding of the given map
(with respect to the [Ord.compare] ordering), or raise (with respect to the [Ord.compare] ordering), or raise
[Not_found] if the map is empty. [Not_found] if the map is empty.
@since 3.12.0 @since 3.12.0
*) *)
val max_binding: 'a t -> (key * 'a) val max_binding: 'a t -> (key * 'a)
(** Same as {!Map.S.min_binding}, but returns the largest binding (** Same as {!Map.S.min_binding}, but returns the largest binding
of the given map. of the given map.
@since 3.12.0 @since 3.12.0
*) *)
val choose: 'a t -> (key * 'a) val choose: 'a t -> (key * 'a)
(** Return one binding of the given map, or raise [Not_found] if (** Return one binding of the given map, or raise [Not_found] if
the map is empty. Which binding is chosen is unspecified, the map is empty. Which binding is chosen is unspecified,
but equal bindings will be chosen for equal maps. but equal bindings will be chosen for equal maps.
@since 3.12.0 @since 3.12.0
*) *)
val split: key -> 'a t -> 'a t * 'a option * 'a t val split: key -> 'a t -> 'a t * 'a option * 'a t
(** [split x m] returns a triple [(l, data, r)], where (** [split x m] returns a triple [(l, data, r)], where
[l] is the map with all the bindings of [m] whose key [l] is the map with all the bindings of [m] whose key
is strictly less than [x]; is strictly less than [x];
[r] is the map with all the bindings of [m] whose key [r] is the map with all the bindings of [m] whose key
is strictly greater than [x]; is strictly greater than [x];
[data] is [None] if [m] contains no binding for [x], [data] is [None] if [m] contains no binding for [x],
or [Some v] if [m] binds [v] to [x]. or [Some v] if [m] binds [v] to [x].
@since 3.12.0 @since 3.12.0
*) *)
val find: key -> 'a t -> 'a val find: key -> 'a t -> 'a
(** [find x m] returns the current binding of [x] in [m], (** [find x m] returns the current binding of [x] in [m],
or raises [Not_found] if no such binding exists. *) or raises [Not_found] if no such binding exists. *)
val map: ('a -> 'b) -> 'a t -> 'b t val map: ('a -> 'b) -> 'a t -> 'b t
(** [map f m] returns a map with same domain as [m], where the (** [map f m] returns a map with same domain as [m], where the
associated value [a] of all bindings of [m] has been associated value [a] of all bindings of [m] has been
replaced by the result of the application of [f] to [a]. replaced by the result of the application of [f] to [a].
The bindings are passed to [f] in increasing order The bindings are passed to [f] in increasing order
with respect to the ordering over the type of the keys. *) with respect to the ordering over the type of the keys. *)
val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t val mapi: (key -> 'a -> 'b) -> 'a t -> 'b t
(** Same as {!Map.S.map}, but the function receives as arguments both the (** Same as {!Map.S.map}, but the function receives as arguments both the
key and the associated value for each binding of the map. *) key and the associated value for each binding of the map. *)
end end
(** Output signature of the functor {!Map.Make}. *) (** Output signature of the functor {!Map.Make}. *)
module Make (Ord : OrderedType) : S with type key = Ord.t module Make (Ord : OrderedType) : S with type key = Ord.t
(** Functor building an implementation of the map structure (** Functor building an implementation of the map structure
given a totally ordered type. *) given a totally ordered type. *)

View File

@ -152,17 +152,17 @@ module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE)
OCaml map as an explicitly synchronized in-memory buffer. *) OCaml map as an explicitly synchronized in-memory buffer. *)
module MakeBufferedPersistentMap module MakeBufferedPersistentMap
(S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t)
: BUFFERED_PERSISTENT_MAP : BUFFERED_PERSISTENT_MAP
with type t := S.t with type t := S.t
and type key := K.t and type key := K.t
and type value := C.t and type value := C.t
and module Map := Map and module Map := Map
(** {2 Predefined Instances} *************************************************) (** {2 Predefined Instances} *************************************************)
module MakePersistentBytesMap (S : STORE) (K : KEY) module MakePersistentBytesMap (S : STORE) (K : KEY)
: PERSISTENT_MAP : PERSISTENT_MAP
with type t := S.t and type key := K.t and type value := MBytes.t with type t := S.t and type key := K.t and type value := MBytes.t
module MakeBufferedPersistentBytesMap module MakeBufferedPersistentBytesMap
(S : STORE) (K : KEY) (Map : Map.S with type key = K.t) (S : STORE) (K : KEY) (Map : Map.S with type key = K.t)

View File

@ -26,13 +26,13 @@
(** The initially opened module. (** The initially opened module.
This module provides the basic operations over the built-in types This module provides the basic operations over the built-in types
(numbers, booleans, byte sequences, strings, exceptions, references, (numbers, booleans, byte sequences, strings, exceptions, references,
lists, arrays, input-output channels, ...). lists, arrays, input-output channels, ...).
This module is automatically opened at the beginning of each compilation. This module is automatically opened at the beginning of each compilation.
All components of this module can therefore be referred by their short All components of this module can therefore be referred by their short
name, without prefixing them by [Pervasives]. name, without prefixing them by [Pervasives].
*) *)
@ -64,14 +64,14 @@ external not : bool -> bool = "%boolnot"
external ( && ) : bool -> bool -> bool = "%sequand" external ( && ) : bool -> bool -> bool = "%sequand"
(** The boolean 'and'. Evaluation is sequential, left-to-right: (** The boolean 'and'. Evaluation is sequential, left-to-right:
in [e1 && e2], [e1] is evaluated first, and if it returns [false], in [e1 && e2], [e1] is evaluated first, and if it returns [false],
[e2] is not evaluated at all. *) [e2] is not evaluated at all. *)
external ( || ) : bool -> bool -> bool = "%sequor" external ( || ) : bool -> bool -> bool = "%sequor"
(** The boolean 'or'. Evaluation is sequential, left-to-right: (** The boolean 'or'. Evaluation is sequential, left-to-right:
in [e1 || e2], [e1] is evaluated first, and if it returns [true], in [e1 || e2], [e1] is evaluated first, and if it returns [true],
[e2] is not evaluated at all. *) [e2] is not evaluated at all. *)
(** {6 Debugging} *) (** {6 Debugging} *)
@ -107,7 +107,7 @@ external __POS__ : string * int * int * int = "%loc_POS"
filename, [lnum] the line number, [cnum] the character position in filename, [lnum] the line number, [cnum] the character position in
the line and [enum] the last character position in the line. the line and [enum] the last character position in the line.
@since 4.02.0 @since 4.02.0
*) *)
external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC" external __LOC_OF__ : 'a -> string * 'a = "%loc_LOC"
(** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the (** [__LOC_OF__ expr] returns a pair [(loc, expr)] where [loc] is the
@ -122,7 +122,7 @@ external __LINE_OF__ : 'a -> int * 'a = "%loc_LINE"
line number at which the expression [expr] appears in the file line number at which the expression [expr] appears in the file
currently being parsed by the compiler. currently being parsed by the compiler.
@since 4.02.0 @since 4.02.0
*) *)
external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS" external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
(** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a (** [__POS_OF__ expr] returns a pair [(loc,expr)], where [loc] is a
@ -132,27 +132,27 @@ external __POS_OF__ : 'a -> (string * int * int * int) * 'a = "%loc_POS"
line number, [cnum] the character position in the line and [enum] line number, [cnum] the character position in the line and [enum]
the last character position in the line. the last character position in the line.
@since 4.02.0 @since 4.02.0
*) *)
(** {6 Composition operators} *) (** {6 Composition operators} *)
external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply"
(** Reverse-application operator: [x |> f |> g] is exactly equivalent (** Reverse-application operator: [x |> f |> g] is exactly equivalent
to [g (f (x))]. to [g (f (x))].
@since 4.01 @since 4.01
*) *)
external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"
(** Application operator: [g @@ f @@ x] is exactly equivalent to (** Application operator: [g @@ f @@ x] is exactly equivalent to
[g (f (x))]. [g (f (x))].
@since 4.01 @since 4.01
*) *)
(** {6 Integer arithmetic} *) (** {6 Integer arithmetic} *)
(** Integers are 31 bits wide (or 63 bits on 64-bit processors). (** Integers are 31 bits wide (or 63 bits on 64-bit processors).
All operations are taken modulo 2{^31} (or 2{^63}). All operations are taken modulo 2{^31} (or 2{^63}).
They do not fail on overflow. *) They do not fail on overflow. *)
external ( ~- ) : int -> int = "%negint" external ( ~- ) : int -> int = "%negint"
(** Unary negation. You can also write [- e] instead of [~- e]. *) (** Unary negation. You can also write [- e] instead of [~- e]. *)
@ -179,24 +179,24 @@ external ( * ) : int -> int -> int = "%mulint"
external ( / ) : int -> int -> int = "%divint" external ( / ) : int -> int -> int = "%divint"
(** Integer division. (** Integer division.
Raise [Division_by_zero] if the second argument is 0. Raise [Division_by_zero] if the second argument is 0.
Integer division rounds the real quotient of its arguments towards zero. Integer division rounds the real quotient of its arguments towards zero.
More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer More precisely, if [x >= 0] and [y > 0], [x / y] is the greatest integer
less than or equal to the real quotient of [x] by [y]. Moreover, less than or equal to the real quotient of [x] by [y]. Moreover,
[(- x) / y = x / (- y) = - (x / y)]. *) [(- x) / y = x / (- y) = - (x / y)]. *)
external ( mod ) : int -> int -> int = "%modint" external ( mod ) : int -> int -> int = "%modint"
(** Integer remainder. If [y] is not zero, the result (** Integer remainder. If [y] is not zero, the result
of [x mod y] satisfies the following properties: of [x mod y] satisfies the following properties:
[x = (x / y) * y + x mod y] and [x = (x / y) * y + x mod y] and
[abs(x mod y) <= abs(y) - 1]. [abs(x mod y) <= abs(y) - 1].
If [y = 0], [x mod y] raises [Division_by_zero]. If [y = 0], [x mod y] raises [Division_by_zero].
Note that [x mod y] is negative only if [x < 0]. Note that [x mod y] is negative only if [x < 0].
Raise [Division_by_zero] if [y] is zero. *) Raise [Division_by_zero] if [y] is zero. *)
val abs : int -> int val abs : int -> int
(** Return the absolute value of the argument. Note that this may be (** Return the absolute value of the argument. Note that this may be
negative if the argument is [min_int]. *) negative if the argument is [min_int]. *)
val max_int : int val max_int : int
(** The greatest representable integer. *) (** The greatest representable integer. *)
@ -221,34 +221,34 @@ val lnot : int -> int
external ( lsl ) : int -> int -> int = "%lslint" external ( lsl ) : int -> int -> int = "%lslint"
(** [n lsl m] shifts [n] to the left by [m] bits. (** [n lsl m] shifts [n] to the left by [m] bits.
The result is unspecified if [m < 0] or [m >= bitsize], The result is unspecified if [m < 0] or [m >= bitsize],
where [bitsize] is [32] on a 32-bit platform and where [bitsize] is [32] on a 32-bit platform and
[64] on a 64-bit platform. *) [64] on a 64-bit platform. *)
external ( lsr ) : int -> int -> int = "%lsrint" external ( lsr ) : int -> int -> int = "%lsrint"
(** [n lsr m] shifts [n] to the right by [m] bits. (** [n lsr m] shifts [n] to the right by [m] bits.
This is a logical shift: zeroes are inserted regardless of This is a logical shift: zeroes are inserted regardless of
the sign of [n]. the sign of [n].
The result is unspecified if [m < 0] or [m >= bitsize]. *) The result is unspecified if [m < 0] or [m >= bitsize]. *)
external ( asr ) : int -> int -> int = "%asrint" external ( asr ) : int -> int -> int = "%asrint"
(** [n asr m] shifts [n] to the right by [m] bits. (** [n asr m] shifts [n] to the right by [m] bits.
This is an arithmetic shift: the sign bit of [n] is replicated. This is an arithmetic shift: the sign bit of [n] is replicated.
The result is unspecified if [m < 0] or [m >= bitsize]. *) The result is unspecified if [m < 0] or [m >= bitsize]. *)
(** {6 Floating-point arithmetic} (** {6 Floating-point arithmetic}
OCaml's floating-point numbers follow the OCaml's floating-point numbers follow the
IEEE 754 standard, using double precision (64 bits) numbers. IEEE 754 standard, using double precision (64 bits) numbers.
Floating-point operations never raise an exception on overflow, Floating-point operations never raise an exception on overflow,
underflow, division by zero, etc. Instead, special IEEE numbers underflow, division by zero, etc. Instead, special IEEE numbers
are returned as appropriate, such as [infinity] for [1.0 /. 0.0], are returned as appropriate, such as [infinity] for [1.0 /. 0.0],
[neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number')
for [0.0 /. 0.0]. These special numbers then propagate through for [0.0 /. 0.0]. These special numbers then propagate through
floating-point computations as expected: for instance, floating-point computations as expected: for instance,
[1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan]
as argument returns [nan] as result. as argument returns [nan] as result.
*) *)
external ( ~-. ) : float -> float = "%negfloat" external ( ~-. ) : float -> float = "%negfloat"
@ -272,13 +272,13 @@ external ( /. ) : float -> float -> float = "%divfloat"
(** Floating-point division. *) (** Floating-point division. *)
external ceil : float -> float = "caml_ceil_float" "ceil" external ceil : float -> float = "caml_ceil_float" "ceil"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Round above to an integer value. (** Round above to an integer value.
[ceil f] returns the least integer value greater than or equal to [f]. [ceil f] returns the least integer value greater than or equal to [f].
The result is returned as a float. *) The result is returned as a float. *)
external floor : float -> float = "caml_floor_float" "floor" external floor : float -> float = "caml_floor_float" "floor"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** Round below to an integer value. (** Round below to an integer value.
[floor f] returns the greatest integer value less than or [floor f] returns the greatest integer value less than or
equal to [f]. equal to [f].
@ -288,26 +288,26 @@ external abs_float : float -> float = "%absfloat"
(** [abs_float f] returns the absolute value of [f]. *) (** [abs_float f] returns the absolute value of [f]. *)
external copysign : float -> float -> float external copysign : float -> float -> float
= "caml_copysign_float" "caml_copysign" = "caml_copysign_float" "caml_copysign"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** [copysign x y] returns a float whose absolute value is that of [x] (** [copysign x y] returns a float whose absolute value is that of [x]
and whose sign is that of [y]. If [x] is [nan], returns [nan]. and whose sign is that of [y]. If [x] is [nan], returns [nan].
If [y] is [nan], returns either [x] or [-. x], but it is not If [y] is [nan], returns either [x] or [-. x], but it is not
specified which. specified which.
@since 4.00.0 *) @since 4.00.0 *)
external mod_float : float -> float -> float = "caml_fmod_float" "fmod" external mod_float : float -> float -> float = "caml_fmod_float" "fmod"
[@@unboxed] [@@noalloc] [@@unboxed] [@@noalloc]
(** [mod_float a b] returns the remainder of [a] with respect to (** [mod_float a b] returns the remainder of [a] with respect to
[b]. The returned value is [a -. n *. b], where [n] [b]. The returned value is [a -. n *. b], where [n]
is the quotient [a /. b] rounded towards zero to an integer. *) is the quotient [a /. b] rounded towards zero to an integer. *)
external frexp : float -> float * int = "caml_frexp_float" external frexp : float -> float * int = "caml_frexp_float"
(** [frexp f] returns the pair of the significant (** [frexp f] returns the pair of the significant
and the exponent of [f]. When [f] is zero, the and the exponent of [f]. When [f] is zero, the
significant [x] and the exponent [n] of [f] are equal to significant [x] and the exponent [n] of [f] are equal to
zero. When [f] is non-zero, they are defined by zero. When [f] is non-zero, they are defined by
[f = x *. 2 ** n] and [0.5 <= x < 1.0]. *) [f = x *. 2 ** n] and [0.5 <= x < 1.0]. *)
external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) = external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
@ -316,7 +316,7 @@ external ldexp : (float [@unboxed]) -> (int [@untagged]) -> (float [@unboxed]) =
external modf : float -> float * float = "caml_modf_float" external modf : float -> float * float = "caml_modf_float"
(** [modf f] returns the pair of the fractional and integral (** [modf f] returns the pair of the fractional and integral
part of [f]. *) part of [f]. *)
external float : int -> float = "%floatofint" external float : int -> float = "%floatofint"
(** Same as {!Pervasives.float_of_int}. *) (** Same as {!Pervasives.float_of_int}. *)
@ -329,8 +329,8 @@ external truncate : float -> int = "%intoffloat"
external int_of_float : float -> int = "%intoffloat" external int_of_float : float -> int = "%intoffloat"
(** Truncate the given floating-point number to an integer. (** Truncate the given floating-point number to an integer.
The result is unspecified if the argument is [nan] or falls outside the The result is unspecified if the argument is [nan] or falls outside the
range of representable integers. *) range of representable integers. *)
val infinity : float val infinity : float
(** Positive infinity. *) (** Positive infinity. *)
@ -340,11 +340,11 @@ val neg_infinity : float
val nan : float val nan : float
(** A special floating-point value denoting the result of an (** A special floating-point value denoting the result of an
undefined operation such as [0.0 /. 0.0]. Stands for undefined operation such as [0.0 /. 0.0]. Stands for
'not a number'. Any floating-point operation with [nan] as 'not a number'. Any floating-point operation with [nan] as
argument returns [nan] as result. As for floating-point comparisons, argument returns [nan] as result. As for floating-point comparisons,
[=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true]
if one or both of their arguments is [nan]. *) if one or both of their arguments is [nan]. *)
val max_float : float val max_float : float
(** The largest positive finite value of type [float]. *) (** The largest positive finite value of type [float]. *)
@ -363,17 +363,17 @@ type fpclass =
| FP_infinite (** Number is positive or negative infinity *) | FP_infinite (** Number is positive or negative infinity *)
| FP_nan (** Not a number: result of an undefined operation *) | FP_nan (** Not a number: result of an undefined operation *)
(** The five classes of floating-point numbers, as determined by (** The five classes of floating-point numbers, as determined by
the {!Pervasives.classify_float} function. *) the {!Pervasives.classify_float} function. *)
external classify_float : (float [@unboxed]) -> fpclass = external classify_float : (float [@unboxed]) -> fpclass =
"caml_classify_float" "caml_classify_float_unboxed" [@@noalloc] "caml_classify_float" "caml_classify_float_unboxed" [@@noalloc]
(** Return the class of the given floating-point number: (** Return the class of the given floating-point number:
normal, subnormal, zero, infinite, or not a number. *) normal, subnormal, zero, infinite, or not a number. *)
(** {6 String operations} (** {6 String operations}
More string operations are provided in module {!String}. More string operations are provided in module {!String}.
*) *)
val ( ^ ) : string -> string -> string val ( ^ ) : string -> string -> string
@ -382,7 +382,7 @@ val ( ^ ) : string -> string -> string
(** {6 Character operations} (** {6 Character operations}
More character operations are provided in module {!Char}. More character operations are provided in module {!Char}.
*) *)
external int_of_char : char -> int = "%identity" external int_of_char : char -> int = "%identity"
@ -390,66 +390,66 @@ external int_of_char : char -> int = "%identity"
val char_of_int : int -> char val char_of_int : int -> char
(** Return the character with the given ASCII code. (** Return the character with the given ASCII code.
Raise [Invalid_argument "char_of_int"] if the argument is Raise [Invalid_argument "char_of_int"] if the argument is
outside the range 0--255. *) outside the range 0--255. *)
(** {6 Unit operations} *) (** {6 Unit operations} *)
external ignore : 'a -> unit = "%ignore" external ignore : 'a -> unit = "%ignore"
(** Discard the value of its argument and return [()]. (** Discard the value of its argument and return [()].
For instance, [ignore(f x)] discards the result of For instance, [ignore(f x)] discards the result of
the side-effecting function [f]. It is equivalent to the side-effecting function [f]. It is equivalent to
[f x; ()], except that the latter may generate a [f x; ()], except that the latter may generate a
compiler warning; writing [ignore(f x)] instead compiler warning; writing [ignore(f x)] instead
avoids the warning. *) avoids the warning. *)
(** {6 String conversion functions} *) (** {6 String conversion functions} *)
val string_of_bool : bool -> string val string_of_bool : bool -> string
(** Return the string representation of a boolean. As the returned values (** Return the string representation of a boolean. As the returned values
may be shared, the user should not modify them directly. may be shared, the user should not modify them directly.
*) *)
val bool_of_string : string -> bool val bool_of_string : string -> bool
(** Convert the given string to a boolean. (** Convert the given string to a boolean.
Raise [Invalid_argument "bool_of_string"] if the string is not Raise [Invalid_argument "bool_of_string"] if the string is not
["true"] or ["false"]. *) ["true"] or ["false"]. *)
val string_of_int : int -> string val string_of_int : int -> string
(** Return the string representation of an integer, in decimal. *) (** Return the string representation of an integer, in decimal. *)
external int_of_string : string -> int = "caml_int_of_string" external int_of_string : string -> int = "caml_int_of_string"
(** Convert the given string to an integer. (** Convert the given string to an integer.
The string is read in decimal (by default), in hexadecimal (if it The string is read in decimal (by default), in hexadecimal (if it
begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]), begins with [0x] or [0X]), in octal (if it begins with [0o] or [0O]),
or in binary (if it begins with [0b] or [0B]). or in binary (if it begins with [0b] or [0B]).
The [_] (underscore) character can appear anywhere in the string The [_] (underscore) character can appear anywhere in the string
and is ignored. and is ignored.
Raise [Failure "int_of_string"] if the given string is not Raise [Failure "int_of_string"] if the given string is not
a valid representation of an integer, or if the integer represented a valid representation of an integer, or if the integer represented
exceeds the range of integers representable in type [int]. *) exceeds the range of integers representable in type [int]. *)
val string_of_float : float -> string val string_of_float : float -> string
(** Return the string representation of a floating-point number. *) (** Return the string representation of a floating-point number. *)
external float_of_string : string -> float = "caml_float_of_string" external float_of_string : string -> float = "caml_float_of_string"
(** Convert the given string to a float. The string is read in decimal (** Convert the given string to a float. The string is read in decimal
(by default) or in hexadecimal (marked by [0x] or [0X]). (by default) or in hexadecimal (marked by [0x] or [0X]).
The format of decimal floating-point numbers is The format of decimal floating-point numbers is
[ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit. [ [-] dd.ddd (e|E) [+|-] dd ], where [d] stands for a decimal digit.
The format of hexadecimal floating-point numbers is The format of hexadecimal floating-point numbers is
[ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an [ [-] 0(x|X) hh.hhh (p|P) [+|-] dd ], where [h] stands for an
hexadecimal digit and [d] for a decimal digit. hexadecimal digit and [d] for a decimal digit.
In both cases, at least one of the integer and fractional parts must be In both cases, at least one of the integer and fractional parts must be
given; the exponent part is optional. given; the exponent part is optional.
The [_] (underscore) character can appear anywhere in the string The [_] (underscore) character can appear anywhere in the string
and is ignored. and is ignored.
Depending on the execution platforms, other representations of Depending on the execution platforms, other representations of
floating-point numbers can be accepted, but should not be relied upon. floating-point numbers can be accepted, but should not be relied upon.
Raise [Failure "float_of_string"] if the given string is not a valid Raise [Failure "float_of_string"] if the given string is not a valid
representation of a float. *) representation of a float. *)
(** {6 Pair operations} *) (** {6 Pair operations} *)
@ -462,7 +462,7 @@ external snd : 'a * 'b -> 'b = "%field1"
(** {6 List operations} (** {6 List operations}
More list operations are provided in module {!List}. More list operations are provided in module {!List}.
*) *)
val ( @ ) : 'a list -> 'a list -> 'a list val ( @ ) : 'a list -> 'a list -> 'a list
@ -473,26 +473,26 @@ val ( @ ) : 'a list -> 'a list -> 'a list
type 'a ref = { mutable contents : 'a } type 'a ref = { mutable contents : 'a }
(** The type of references (mutable indirection cells) containing (** The type of references (mutable indirection cells) containing
a value of type ['a]. *) a value of type ['a]. *)
external ref : 'a -> 'a ref = "%makemutable" external ref : 'a -> 'a ref = "%makemutable"
(** Return a fresh reference containing the given value. *) (** Return a fresh reference containing the given value. *)
external ( ! ) : 'a ref -> 'a = "%field0" external ( ! ) : 'a ref -> 'a = "%field0"
(** [!r] returns the current contents of reference [r]. (** [!r] returns the current contents of reference [r].
Equivalent to [fun r -> r.contents]. *) Equivalent to [fun r -> r.contents]. *)
external ( := ) : 'a ref -> 'a -> unit = "%setfield0" external ( := ) : 'a ref -> 'a -> unit = "%setfield0"
(** [r := a] stores the value of [a] in reference [r]. (** [r := a] stores the value of [a] in reference [r].
Equivalent to [fun r v -> r.contents <- v]. *) Equivalent to [fun r v -> r.contents <- v]. *)
external incr : int ref -> unit = "%incr" external incr : int ref -> unit = "%incr"
(** Increment the integer contained in the given reference. (** Increment the integer contained in the given reference.
Equivalent to [fun r -> r := succ !r]. *) Equivalent to [fun r -> r := succ !r]. *)
external decr : int ref -> unit = "%decr" external decr : int ref -> unit = "%decr"
(** Decrement the integer contained in the given reference. (** Decrement the integer contained in the given reference.
Equivalent to [fun r -> r := pred !r]. *) Equivalent to [fun r -> r := pred !r]. *)
(** {6 Result type} *) (** {6 Result type} *)
@ -501,30 +501,30 @@ type ('a,'b) result = Ok of 'a | Error of 'b
(** {6 Operations on format strings} *) (** {6 Operations on format strings} *)
(** Format strings are character strings with special lexical conventions (** Format strings are character strings with special lexical conventions
that defines the functionality of formatted input/output functions. Format that defines the functionality of formatted input/output functions. Format
strings are used to read data with formatted input functions from module strings are used to read data with formatted input functions from module
{!Scanf} and to print data with formatted output functions from modules {!Scanf} and to print data with formatted output functions from modules
{!Printf} and {!Format}. {!Printf} and {!Format}.
Format strings are made of three kinds of entities: Format strings are made of three kinds of entities:
- {e conversions specifications}, introduced by the special character ['%'] - {e conversions specifications}, introduced by the special character ['%']
followed by one or more characters specifying what kind of argument to followed by one or more characters specifying what kind of argument to
read or print, read or print,
- {e formatting indications}, introduced by the special character ['@'] - {e formatting indications}, introduced by the special character ['@']
followed by one or more characters specifying how to read or print the followed by one or more characters specifying how to read or print the
argument, argument,
- {e plain characters} that are regular characters with usual lexical - {e plain characters} that are regular characters with usual lexical
conventions. Plain characters specify string literals to be read in the conventions. Plain characters specify string literals to be read in the
input or printed in the output. input or printed in the output.
There is an additional lexical rule to escape the special characters ['%'] There is an additional lexical rule to escape the special characters ['%']
and ['@'] in format strings: if a special character follows a ['%'] and ['@'] in format strings: if a special character follows a ['%']
character, it is treated as a plain character. In other words, ["%%"] is character, it is treated as a plain character. In other words, ["%%"] is
considered as a plain ['%'] and ["%@"] as a plain ['@']. considered as a plain ['%'] and ["%@"] as a plain ['@'].
For more information about conversion specifications and formatting For more information about conversion specifications and formatting
indications available, read the documentation of modules {!Scanf}, indications available, read the documentation of modules {!Scanf},
{!Printf} and {!Format}. {!Printf} and {!Format}.
*) *)
(** Format strings have a general and highly polymorphic type (** Format strings have a general and highly polymorphic type
@ -593,9 +593,9 @@ val ( ^^ ) :
('f, 'b, 'c, 'e, 'g, 'h) format6 -> ('f, 'b, 'c, 'e, 'g, 'h) format6 ->
('a, 'b, 'c, 'd, 'g, 'h) format6 ('a, 'b, 'c, 'd, 'g, 'h) format6
(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a (** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a
format string that behaves as the concatenation of format strings [f1] and format string that behaves as the concatenation of format strings [f1] and
[f2]: in case of formatted output, it accepts arguments from [f1], then [f2]: in case of formatted output, it accepts arguments from [f1], then
arguments from [f2]; in case of formatted input, it returns results from arguments from [f2]; in case of formatted input, it returns results from
[f1], then results from [f2]. [f1], then results from [f2].
*) *)

View File

@ -15,191 +15,191 @@
(** Sets over ordered types. (** Sets over ordered types.
This module implements the set data structure, given a total ordering This module implements the set data structure, given a total ordering
function over the set elements. All operations over sets function over the set elements. All operations over sets
are purely applicative (no side-effects). are purely applicative (no side-effects).
The implementation uses balanced binary trees, and is therefore The implementation uses balanced binary trees, and is therefore
reasonably efficient: insertion and membership take time reasonably efficient: insertion and membership take time
logarithmic in the size of the set, for instance. logarithmic in the size of the set, for instance.
The [Make] functor constructs implementations for any type, given a The [Make] functor constructs implementations for any type, given a
[compare] function. [compare] function.
For instance: For instance:
{[ {[
module IntPairs = module IntPairs =
struct struct
type t = int * int type t = int * int
let compare (x0,y0) (x1,y1) = let compare (x0,y0) (x1,y1) =
match Pervasives.compare x0 x1 with match Pervasives.compare x0 x1 with
0 -> Pervasives.compare y0 y1 0 -> Pervasives.compare y0 y1
| c -> c | c -> c
end end
module PairsSet = Set.Make(IntPairs) module PairsSet = Set.Make(IntPairs)
let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13)) let m = PairsSet.(empty |> add (2,3) |> add (5,7) |> add (11,13))
]} ]}
This creates a new module [PairsSet], with a new type [PairsSet.t] This creates a new module [PairsSet], with a new type [PairsSet.t]
of sets of [int * int]. of sets of [int * int].
*) *)
module type OrderedType = module type OrderedType =
sig sig
type t type t
(** The type of the set elements. *) (** The type of the set elements. *)
val compare : t -> t -> int val compare : t -> t -> int
(** A total ordering function over the set elements. (** A total ordering function over the set elements.
This is a two-argument function [f] such that This is a two-argument function [f] such that
[f e1 e2] is zero if the elements [e1] and [e2] are equal, [f e1 e2] is zero if the elements [e1] and [e2] are equal,
[f e1 e2] is strictly negative if [e1] is smaller than [e2], [f e1 e2] is strictly negative if [e1] is smaller than [e2],
and [f e1 e2] is strictly positive if [e1] is greater than [e2]. and [f e1 e2] is strictly positive if [e1] is greater than [e2].
Example: a suitable ordering function is the generic structural Example: a suitable ordering function is the generic structural
comparison function {!Pervasives.compare}. *) comparison function {!Pervasives.compare}. *)
end end
(** Input signature of the functor {!Set.Make}. *) (** Input signature of the functor {!Set.Make}. *)
module type S = module type S =
sig sig
type elt type elt
(** The type of the set elements. *) (** The type of the set elements. *)
type t type t
(** The type of sets. *) (** The type of sets. *)
val empty: t val empty: t
(** The empty set. *) (** The empty set. *)
val is_empty: t -> bool val is_empty: t -> bool
(** Test whether a set is empty or not. *) (** Test whether a set is empty or not. *)
val mem: elt -> t -> bool val mem: elt -> t -> bool
(** [mem x s] tests whether [x] belongs to the set [s]. *) (** [mem x s] tests whether [x] belongs to the set [s]. *)
val add: elt -> t -> t val add: elt -> t -> t
(** [add x s] returns a set containing all elements of [s], (** [add x s] returns a set containing all elements of [s],
plus [x]. If [x] was already in [s], [s] is returned unchanged plus [x]. If [x] was already in [s], [s] is returned unchanged
(the result of the function is then physically equal to [s]). (the result of the function is then physically equal to [s]).
@before 4.03 Physical equality was not ensured. *) @before 4.03 Physical equality was not ensured. *)
val singleton: elt -> t val singleton: elt -> t
(** [singleton x] returns the one-element set containing only [x]. *) (** [singleton x] returns the one-element set containing only [x]. *)
val remove: elt -> t -> t val remove: elt -> t -> t
(** [remove x s] returns a set containing all elements of [s], (** [remove x s] returns a set containing all elements of [s],
except [x]. If [x] was not in [s], [s] is returned unchanged except [x]. If [x] was not in [s], [s] is returned unchanged
(the result of the function is then physically equal to [s]). (the result of the function is then physically equal to [s]).
@before 4.03 Physical equality was not ensured. *) @before 4.03 Physical equality was not ensured. *)
val union: t -> t -> t val union: t -> t -> t
(** Set union. *) (** Set union. *)
val inter: t -> t -> t val inter: t -> t -> t
(** Set intersection. *) (** Set intersection. *)
val diff: t -> t -> t val diff: t -> t -> t
(** Set difference. *) (** Set difference. *)
val compare: t -> t -> int val compare: t -> t -> int
(** Total ordering between sets. Can be used as the ordering function (** Total ordering between sets. Can be used as the ordering function
for doing sets of sets. *) for doing sets of sets. *)
val equal: t -> t -> bool val equal: t -> t -> bool
(** [equal s1 s2] tests whether the sets [s1] and [s2] are (** [equal s1 s2] tests whether the sets [s1] and [s2] are
equal, that is, contain equal elements. *) equal, that is, contain equal elements. *)
val subset: t -> t -> bool val subset: t -> t -> bool
(** [subset s1 s2] tests whether the set [s1] is a subset of (** [subset s1 s2] tests whether the set [s1] is a subset of
the set [s2]. *) the set [s2]. *)
val iter: (elt -> unit) -> t -> unit val iter: (elt -> unit) -> t -> unit
(** [iter f s] applies [f] in turn to all elements of [s]. (** [iter f s] applies [f] in turn to all elements of [s].
The elements of [s] are presented to [f] in increasing order The elements of [s] are presented to [f] in increasing order
with respect to the ordering over the type of the elements. *) with respect to the ordering over the type of the elements. *)
val map: (elt -> elt) -> t -> t val map: (elt -> elt) -> t -> t
(** [map f s] is the set whose elements are [f a0],[f a1]... [f (** [map f s] is the set whose elements are [f a0],[f a1]... [f
aN], where [a0],[a1]...[aN] are the elements of [s]. aN], where [a0],[a1]...[aN] are the elements of [s].
The elements are passed to [f] in increasing order The elements are passed to [f] in increasing order
with respect to the ordering over the type of the elements. with respect to the ordering over the type of the elements.
If no element of [s] is changed by [f], [s] is returned If no element of [s] is changed by [f], [s] is returned
unchanged. (If each output of [f] is physically equal to its unchanged. (If each output of [f] is physically equal to its
input, the returned set is physically equal to [s].) *) input, the returned set is physically equal to [s].) *)
val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a val fold: (elt -> 'a -> 'a) -> t -> 'a -> 'a
(** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
where [x1 ... xN] are the elements of [s], in increasing order. *) where [x1 ... xN] are the elements of [s], in increasing order. *)
val for_all: (elt -> bool) -> t -> bool val for_all: (elt -> bool) -> t -> bool
(** [for_all p s] checks if all elements of the set (** [for_all p s] checks if all elements of the set
satisfy the predicate [p]. *) satisfy the predicate [p]. *)
val exists: (elt -> bool) -> t -> bool val exists: (elt -> bool) -> t -> bool
(** [exists p s] checks if at least one element of (** [exists p s] checks if at least one element of
the set satisfies the predicate [p]. *) the set satisfies the predicate [p]. *)
val filter: (elt -> bool) -> t -> t val filter: (elt -> bool) -> t -> t
(** [filter p s] returns the set of all elements in [s] (** [filter p s] returns the set of all elements in [s]
that satisfy predicate [p]. If [p] satisfies every element in [s], that satisfy predicate [p]. If [p] satisfies every element in [s],
[s] is returned unchanged (the result of the function is then [s] is returned unchanged (the result of the function is then
physically equal to [s]). physically equal to [s]).
@before 4.03 Physical equality was not ensured.*) @before 4.03 Physical equality was not ensured.*)
val partition: (elt -> bool) -> t -> t * t val partition: (elt -> bool) -> t -> t * t
(** [partition p s] returns a pair of sets [(s1, s2)], where (** [partition p s] returns a pair of sets [(s1, s2)], where
[s1] is the set of all the elements of [s] that satisfy the [s1] is the set of all the elements of [s] that satisfy the
predicate [p], and [s2] is the set of all the elements of predicate [p], and [s2] is the set of all the elements of
[s] that do not satisfy [p]. *) [s] that do not satisfy [p]. *)
val cardinal: t -> int val cardinal: t -> int
(** Return the number of elements of a set. *) (** Return the number of elements of a set. *)
val elements: t -> elt list val elements: t -> elt list
(** Return the list of all elements of the given set. (** Return the list of all elements of the given set.
The returned list is sorted in increasing order with respect The returned list is sorted in increasing order with respect
to the ordering [Ord.compare], where [Ord] is the argument to the ordering [Ord.compare], where [Ord] is the argument
given to {!Set.Make}. *) given to {!Set.Make}. *)
val min_elt: t -> elt val min_elt: t -> elt
(** Return the smallest element of the given set (** Return the smallest element of the given set
(with respect to the [Ord.compare] ordering), or raise (with respect to the [Ord.compare] ordering), or raise
[Not_found] if the set is empty. *) [Not_found] if the set is empty. *)
val max_elt: t -> elt val max_elt: t -> elt
(** Same as {!Set.S.min_elt}, but returns the largest element of the (** Same as {!Set.S.min_elt}, but returns the largest element of the
given set. *) given set. *)
val choose: t -> elt val choose: t -> elt
(** Return one element of the given set, or raise [Not_found] if (** Return one element of the given set, or raise [Not_found] if
the set is empty. Which element is chosen is unspecified, the set is empty. Which element is chosen is unspecified,
but equal elements will be chosen for equal sets. *) but equal elements will be chosen for equal sets. *)
val split: elt -> t -> t * bool * t val split: elt -> t -> t * bool * t
(** [split x s] returns a triple [(l, present, r)], where (** [split x s] returns a triple [(l, present, r)], where
[l] is the set of elements of [s] that are [l] is the set of elements of [s] that are
strictly less than [x]; strictly less than [x];
[r] is the set of elements of [s] that are [r] is the set of elements of [s] that are
strictly greater than [x]; strictly greater than [x];
[present] is [false] if [s] contains no element equal to [x], [present] is [false] if [s] contains no element equal to [x],
or [true] if [s] contains an element equal to [x]. *) or [true] if [s] contains an element equal to [x]. *)
val find: elt -> t -> elt val find: elt -> t -> elt
(** [find x s] returns the element of [s] equal to [x] (according (** [find x s] returns the element of [s] equal to [x] (according
to [Ord.compare]), or raise [Not_found] if no such element to [Ord.compare]), or raise [Not_found] if no such element
exists. exists.
@since 4.01.0 *) @since 4.01.0 *)
val of_list: elt list -> t val of_list: elt list -> t
(** [of_list l] creates a set from a list of elements. (** [of_list l] creates a set from a list of elements.
This is usually more efficient than folding [add] over the list, This is usually more efficient than folding [add] over the list,
except perhaps for lists with many duplicated elements. except perhaps for lists with many duplicated elements.
@since 4.02.0 *) @since 4.02.0 *)
end end
(** Output signature of the functor {!Set.Make}. *) (** Output signature of the functor {!Set.Make}. *)
module Make (Ord : OrderedType) : S with type elt = Ord.t module Make (Ord : OrderedType) : S with type elt = Ord.t
(** Functor building an implementation of the set structure (** Functor building an implementation of the set structure
given a totally ordered type. *) given a totally ordered type. *)

View File

@ -24,40 +24,40 @@
(** String operations. (** String operations.
A string is an immutable data structure that contains a A string is an immutable data structure that contains a
fixed-length sequence of (single-byte) characters. Each character fixed-length sequence of (single-byte) characters. Each character
can be accessed in constant time through its index. can be accessed in constant time through its index.
Given a string [s] of length [l], we can access each of the [l] Given a string [s] of length [l], we can access each of the [l]
characters of [s] via its index in the sequence. Indexes start at characters of [s] via its index in the sequence. Indexes start at
[0], and we will call an index valid in [s] if it falls within the [0], and we will call an index valid in [s] if it falls within the
range [[0...l-1]] (inclusive). A position is the point between two range [[0...l-1]] (inclusive). A position is the point between two
characters or at the beginning or end of the string. We call a characters or at the beginning or end of the string. We call a
position valid in [s] if it falls within the range [[0...l]] position valid in [s] if it falls within the range [[0...l]]
(inclusive). Note that the character at index [n] is between (inclusive). Note that the character at index [n] is between
positions [n] and [n+1]. positions [n] and [n+1].
Two parameters [start] and [len] are said to designate a valid Two parameters [start] and [len] are said to designate a valid
substring of [s] if [len >= 0] and [start] and [start+len] are substring of [s] if [len >= 0] and [start] and [start+len] are
valid positions in [s]. valid positions in [s].
*) *)
external length : string -> int = "%string_length" external length : string -> int = "%string_length"
(** Return the length (number of characters) of the given string. *) (** Return the length (number of characters) of the given string. *)
external get : string -> int -> char = "%string_safe_get" external get : string -> int -> char = "%string_safe_get"
(** [String.get s n] returns the character at index [n] in string [s]. (** [String.get s n] returns the character at index [n] in string [s].
You can also write [s.[n]] instead of [String.get s n]. You can also write [s.[n]] instead of [String.get s n].
Raise [Invalid_argument] if [n] not a valid index in [s]. *) Raise [Invalid_argument] if [n] not a valid index in [s]. *)
val make : int -> char -> string val make : int -> char -> string
(** [String.make n c] returns a fresh string of length [n], (** [String.make n c] returns a fresh string of length [n],
filled with the character [c]. filled with the character [c].
Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *) Raise [Invalid_argument] if [n < 0] or [n > ]{!Sys.max_string_length}. *)
val init : int -> (int -> char) -> string val init : int -> (int -> char) -> string
(** [String.init n f] returns a string of length [n], with character (** [String.init n f] returns a string of length [n], with character
@ -71,11 +71,11 @@ val init : int -> (int -> char) -> string
val sub : string -> int -> int -> string val sub : string -> int -> int -> string
(** [String.sub s start len] returns a fresh string of length [len], (** [String.sub s start len] returns a fresh string of length [len],
containing the substring of [s] that starts at position [start] and containing the substring of [s] that starts at position [start] and
has length [len]. has length [len].
Raise [Invalid_argument] if [start] and [len] do not Raise [Invalid_argument] if [start] and [len] do not
designate a valid substring of [s]. *) designate a valid substring of [s]. *)
val blit : string -> int -> bytes -> int -> int -> unit val blit : string -> int -> bytes -> int -> int -> unit
(** Same as {!Bytes.blit_string}. *) (** Same as {!Bytes.blit_string}. *)
@ -89,14 +89,14 @@ val concat : string -> string list -> string
val iter : (char -> unit) -> string -> unit val iter : (char -> unit) -> string -> unit
(** [String.iter f s] applies function [f] in turn to all (** [String.iter f s] applies function [f] in turn to all
the characters of [s]. It is equivalent to the characters of [s]. It is equivalent to
[f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *) [f s.[0]; f s.[1]; ...; f s.[String.length s - 1]; ()]. *)
val iteri : (int -> char -> unit) -> string -> unit val iteri : (int -> char -> unit) -> string -> unit
(** Same as {!String.iter}, but the (** Same as {!String.iter}, but the
function is applied to the index of the element as first argument function is applied to the index of the element as first argument
(counting from 0), and the character itself as second argument. (counting from 0), and the character itself as second argument.
@since 4.00.0 *) @since 4.00.0 *)
val map : (char -> char) -> string -> string val map : (char -> char) -> string -> string
(** [String.map f s] applies function [f] in turn to all the (** [String.map f s] applies function [f] in turn to all the
@ -112,11 +112,11 @@ val mapi : (int -> char -> char) -> string -> string
val trim : string -> string val trim : string -> string
(** Return a copy of the argument, without leading and trailing (** Return a copy of the argument, without leading and trailing
whitespace. The characters regarded as whitespace are: [' '], whitespace. The characters regarded as whitespace are: [' '],
['\012'], ['\n'], ['\r'], and ['\t']. If there is neither leading nor ['\012'], ['\n'], ['\r'], and ['\t']. If there is neither leading nor
trailing whitespace character in the argument, return the original trailing whitespace character in the argument, return the original
string itself, not a copy. string itself, not a copy.
@since 4.00.0 *) @since 4.00.0 *)
val escaped : string -> string val escaped : string -> string
(** Return a copy of the argument, with special characters (** Return a copy of the argument, with special characters
@ -137,71 +137,71 @@ val escaped : string -> string
val index : string -> char -> int val index : string -> char -> int
(** [String.index s c] returns the index of the first (** [String.index s c] returns the index of the first
occurrence of character [c] in string [s]. occurrence of character [c] in string [s].
Raise [Not_found] if [c] does not occur in [s]. *) Raise [Not_found] if [c] does not occur in [s]. *)
val rindex : string -> char -> int val rindex : string -> char -> int
(** [String.rindex s c] returns the index of the last (** [String.rindex s c] returns the index of the last
occurrence of character [c] in string [s]. occurrence of character [c] in string [s].
Raise [Not_found] if [c] does not occur in [s]. *) Raise [Not_found] if [c] does not occur in [s]. *)
val index_from : string -> int -> char -> int val index_from : string -> int -> char -> int
(** [String.index_from s i c] returns the index of the (** [String.index_from s i c] returns the index of the
first occurrence of character [c] in string [s] after position [i]. first occurrence of character [c] in string [s] after position [i].
[String.index s c] is equivalent to [String.index_from s 0 c]. [String.index s c] is equivalent to [String.index_from s 0 c].
Raise [Invalid_argument] if [i] is not a valid position in [s]. Raise [Invalid_argument] if [i] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] after position [i]. *) Raise [Not_found] if [c] does not occur in [s] after position [i]. *)
val rindex_from : string -> int -> char -> int val rindex_from : string -> int -> char -> int
(** [String.rindex_from s i c] returns the index of the (** [String.rindex_from s i c] returns the index of the
last occurrence of character [c] in string [s] before position [i+1]. last occurrence of character [c] in string [s] before position [i+1].
[String.rindex s c] is equivalent to [String.rindex s c] is equivalent to
[String.rindex_from s (String.length s - 1) c]. [String.rindex_from s (String.length s - 1) c].
Raise [Invalid_argument] if [i+1] is not a valid position in [s]. Raise [Invalid_argument] if [i+1] is not a valid position in [s].
Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *) Raise [Not_found] if [c] does not occur in [s] before position [i+1]. *)
val contains : string -> char -> bool val contains : string -> char -> bool
(** [String.contains s c] tests if character [c] (** [String.contains s c] tests if character [c]
appears in the string [s]. *) appears in the string [s]. *)
val contains_from : string -> int -> char -> bool val contains_from : string -> int -> char -> bool
(** [String.contains_from s start c] tests if character [c] (** [String.contains_from s start c] tests if character [c]
appears in [s] after position [start]. appears in [s] after position [start].
[String.contains s c] is equivalent to [String.contains s c] is equivalent to
[String.contains_from s 0 c]. [String.contains_from s 0 c].
Raise [Invalid_argument] if [start] is not a valid position in [s]. *) Raise [Invalid_argument] if [start] is not a valid position in [s]. *)
val rcontains_from : string -> int -> char -> bool val rcontains_from : string -> int -> char -> bool
(** [String.rcontains_from s stop c] tests if character [c] (** [String.rcontains_from s stop c] tests if character [c]
appears in [s] before position [stop+1]. appears in [s] before position [stop+1].
Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid Raise [Invalid_argument] if [stop < 0] or [stop+1] is not a valid
position in [s]. *) position in [s]. *)
val uppercase_ascii : string -> string val uppercase_ascii : string -> string
(** Return a copy of the argument, with all lowercase letters (** Return a copy of the argument, with all lowercase letters
translated to uppercase, using the US-ASCII character set. translated to uppercase, using the US-ASCII character set.
@since 4.03.0 *) @since 4.03.0 *)
val lowercase_ascii : string -> string val lowercase_ascii : string -> string
(** Return a copy of the argument, with all uppercase letters (** Return a copy of the argument, with all uppercase letters
translated to lowercase, using the US-ASCII character set. translated to lowercase, using the US-ASCII character set.
@since 4.03.0 *) @since 4.03.0 *)
val capitalize_ascii : string -> string val capitalize_ascii : string -> string
(** Return a copy of the argument, with the first character set to uppercase, (** Return a copy of the argument, with the first character set to uppercase,
using the US-ASCII character set. using the US-ASCII character set.
@since 4.03.0 *) @since 4.03.0 *)
val uncapitalize_ascii : string -> string val uncapitalize_ascii : string -> string
(** Return a copy of the argument, with the first character set to lowercase, (** Return a copy of the argument, with the first character set to lowercase,
using the US-ASCII character set. using the US-ASCII character set.
@since 4.03.0 *) @since 4.03.0 *)
type t = string type t = string
(** An alias for the type of strings. *) (** An alias for the type of strings. *)

View File

@ -30,7 +30,7 @@ val ediv_rem: t -> t -> (t * t)
(** Euclidean division and remainder. [ediv_rem a b] returns a pair [(q, r)] (** Euclidean division and remainder. [ediv_rem a b] returns a pair [(q, r)]
such that [a = b * q + r] and [0 <= r < |b|]. such that [a = b * q + r] and [0 <= r < |b|].
Raises [Division_by_zero] if [b = 0]. Raises [Division_by_zero] if [b = 0].
*) *)
external logand: t -> t -> t = "ml_z_logand" "ml_as_z_logand" external logand: t -> t -> t = "ml_z_logand" "ml_as_z_logand"
(** Bitwise logical and. *) (** Bitwise logical and. *)
@ -44,20 +44,20 @@ external logxor: t -> t -> t = "ml_z_logxor" "ml_as_z_logxor"
external lognot: t -> t = "ml_z_lognot" "ml_as_z_lognot" external lognot: t -> t = "ml_z_lognot" "ml_as_z_lognot"
(** Bitwise logical negation. (** Bitwise logical negation.
The identity [lognot a]=[-a-1] always hold. The identity [lognot a]=[-a-1] always hold.
*) *)
external shift_left: t -> int -> t = "ml_z_shift_left" "ml_as_z_shift_left" external shift_left: t -> int -> t = "ml_z_shift_left" "ml_as_z_shift_left"
(** Shifts to the left. (** Shifts to the left.
Equivalent to a multiplication by a power of 2. Equivalent to a multiplication by a power of 2.
The second argument must be non-negative. The second argument must be non-negative.
*) *)
external shift_right: t -> int -> t = "ml_z_shift_right" "ml_as_z_shift_right" external shift_right: t -> int -> t = "ml_z_shift_right" "ml_as_z_shift_right"
(** Shifts to the right. (** Shifts to the right.
This is an arithmetic shift, This is an arithmetic shift,
equivalent to a division by a power of 2 with rounding towards -oo. equivalent to a division by a power of 2 with rounding towards -oo.
The second argument must be non-negative. The second argument must be non-negative.
*) *)
val to_string: t -> string val to_string: t -> string
val of_string: string -> t val of_string: string -> t

View File

@ -31,16 +31,16 @@ let canonical_location_encoding =
int31 int31
let location = function let location = function
| Int (loc, _) -> loc | Int (loc, _) -> loc
| String (loc, _) -> loc | String (loc, _) -> loc
| Seq (loc, _, _) -> loc | Seq (loc, _, _) -> loc
| Prim (loc, _, _, _) -> loc | Prim (loc, _, _, _) -> loc
let annotation = function let annotation = function
| Int (_, _) -> None | Int (_, _) -> None
| String (_, _) -> None | String (_, _) -> None
| Seq (_, _, annot) -> annot | Seq (_, _, annot) -> annot
| Prim (_, _, _, annot) -> annot | Prim (_, _, _, annot) -> annot
let root (Canonical expr) = expr let root (Canonical expr) = expr
@ -100,18 +100,18 @@ let map f (Canonical expr) =
| Seq (loc, seq, annot) -> | Seq (loc, seq, annot) ->
Seq (loc, List.map (map_node f) seq, annot) Seq (loc, List.map (map_node f) seq, annot)
| Prim (loc, name, seq, annot) -> | Prim (loc, name, seq, annot) ->
Prim (loc, f name, List.map (map_node f) seq, annot) in Prim (loc, f name, List.map (map_node f) seq, annot) in
Canonical (map_node f expr) Canonical (map_node f expr)
let rec map_node fl fp = function let rec map_node fl fp = function
| Int (loc, v) -> | Int (loc, v) ->
Int (fl loc, v) Int (fl loc, v)
| String (loc, v) -> | String (loc, v) ->
String (fl loc, v) String (fl loc, v)
| Seq (loc, seq, annot) -> | Seq (loc, seq, annot) ->
Seq (fl loc, List.map (map_node fl fp) seq, annot) Seq (fl loc, List.map (map_node fl fp) seq, annot)
| Prim (loc, name, seq, annot) -> | Prim (loc, name, seq, annot) ->
Prim (fl loc, fp name, List.map (map_node fl fp) seq, annot) Prim (fl loc, fp name, List.map (map_node fl fp) seq, annot)
let canonical_encoding prim_encoding = let canonical_encoding prim_encoding =
let open Data_encoding in let open Data_encoding in

View File

@ -51,11 +51,11 @@ let string_of_method = function
let service ?(meth = default_meth) ?description ~input ~output path = let service ?(meth = default_meth) ?description ~input ~output path =
(meth, (meth,
Resto.service Resto.service
?description ?description
~input:(Data_encoding.Json.convert input) ~input:(Data_encoding.Json.convert input)
~output:(Data_encoding.Json.convert output) ~output:(Data_encoding.Json.convert output)
path) path)
(* REST services *) (* REST services *)

View File

@ -289,10 +289,10 @@ val register_dynamic_directory3:
(** Registring custom directory lookup. *) (** Registring custom directory lookup. *)
type custom_lookup = RestoDirectory.custom_lookup type custom_lookup = RestoDirectory.custom_lookup
(* | CustomService of Description.service_descr * *) (* | CustomService of Description.service_descr * *)
(* ( Data_encoding.json option -> *) (* ( Data_encoding.json option -> *)
(* Data_encoding.json Answer.answer Lwt.t ) *) (* Data_encoding.json Answer.answer Lwt.t ) *)
(* | CustomDirectory of Description.directory_descr *) (* | CustomDirectory of Description.directory_descr *)
val register_custom_lookup: val register_custom_lookup:
?meth:meth -> ?meth:meth ->

View File

@ -89,19 +89,19 @@ module MakeUnsigned(Int : S)(Z : sig val zero : Int.t end) = struct
type t = Int.t type t = Int.t
let compare va vb = let compare va vb =
Int.(if va >= Z.zero then if vb >= Z.zero then compare va vb else -1 Int.(if va >= Z.zero then if vb >= Z.zero then compare va vb else -1
else if vb >= Z.zero then 1 else compare va vb) else if vb >= Z.zero then 1 else compare va vb)
let (=) = ((=) : t -> t -> bool) let (=) = ((=) : t -> t -> bool)
let (<>) = ((<>) : t -> t -> bool) let (<>) = ((<>) : t -> t -> bool)
let (<) a b = let (<) a b =
Int.(if Z.zero <= a then Int.(if Z.zero <= a then
(a < b || b < Z.zero) (a < b || b < Z.zero)
else else
(b < Z.zero && a < b)) (b < Z.zero && a < b))
let (<=) a b = let (<=) a b =
Int.(if Z.zero <= a then Int.(if Z.zero <= a then
(a <= b || b < Z.zero) (a <= b || b < Z.zero)
else else
(b < Z.zero && a <= b)) (b < Z.zero && a <= b))
let (>=) a b = (<=) b a let (>=) a b = (<=) b a
let (>) a b = (<) b a let (>) a b = (<) b a
let max x y = if x >= y then x else y let max x y = if x >= y then x else y

View File

@ -285,34 +285,34 @@ module Json = struct
and lift_union_in_pair and lift_union_in_pair
: type a b. pair_builder -> Kind.t -> a t -> b t -> (a * b) t : type a b. pair_builder -> Kind.t -> a t -> b t -> (a * b) t
= fun b p e1 e2 -> = fun b p e1 e2 ->
match lift_union e1, lift_union e2 with match lift_union e1, lift_union e2 with
| e1, { encoding = Union (_kind, tag, cases) } -> | e1, { encoding = Union (_kind, tag, cases) } ->
make @@ make @@
Union (`Dynamic (* ignored *), tag, Union (`Dynamic (* ignored *), tag,
List.map List.map
(fun (Case { encoding = e2 ; proj ; inj ; tag }) -> (fun (Case { encoding = e2 ; proj ; inj ; tag }) ->
Case { encoding = lift_union_in_pair b p e1 e2 ; Case { encoding = lift_union_in_pair b p e1 e2 ;
proj = (fun (x, y) -> proj = (fun (x, y) ->
match proj y with match proj y with
| None -> None | None -> None
| Some y -> Some (x, y)) ; | Some y -> Some (x, y)) ;
inj = (fun (x, y) -> (x, inj y)) ; inj = (fun (x, y) -> (x, inj y)) ;
tag }) tag })
cases) cases)
| { encoding = Union (_kind, tag, cases) }, e2 -> | { encoding = Union (_kind, tag, cases) }, e2 ->
make @@ make @@
Union (`Dynamic (* ignored *), tag, Union (`Dynamic (* ignored *), tag,
List.map List.map
(fun (Case { encoding = e1 ; proj ; inj ; tag }) -> (fun (Case { encoding = e1 ; proj ; inj ; tag }) ->
Case { encoding = lift_union_in_pair b p e1 e2 ; Case { encoding = lift_union_in_pair b p e1 e2 ;
proj = (fun (x, y) -> proj = (fun (x, y) ->
match proj x with match proj x with
| None -> None | None -> None
| Some x -> Some (x, y)) ; | Some x -> Some (x, y)) ;
inj = (fun (x, y) -> (inj x, y)) ; inj = (fun (x, y) -> (inj x, y)) ;
tag }) tag })
cases) cases)
| e1, e2 -> b.build p e1 e2 | e1, e2 -> b.build p e1 e2
let rec json : type a. a desc -> a Json_encoding.encoding = let rec json : type a. a desc -> a Json_encoding.encoding =
let open Json_encoding in let open Json_encoding in
@ -384,7 +384,7 @@ module Json = struct
| `Star | `Star
(** Any / every field or index. *) (** Any / every field or index. *)
| `Next | `Next
(** The next element after an array. *) ] (** The next element after an array. *) ]
include Json_encoding include Json_encoding
@ -632,7 +632,7 @@ module Encoding = struct
(((h, g), (f, e)), ((d, c), (b, a)))) (((h, g), (f, e)), ((d, c), (b, a))))
(fun (((h, g), (f, e)), ((d, c), (b, a))) -> (fun (((h, g), (f, e)), ((d, c), (b, a))) ->
(h, g, f, e, d, c, b, a)) (h, g, f, e, d, c, b, a))
ty ty
let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1) let obj8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (obj8 f8 f7 f6 f5 f4 f3 f2 f1)
let tup8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1) let tup8 f8 f7 f6 f5 f4 f3 f2 f1 = conv8 (tup8 f8 f7 f6 f5 f4 f3 f2 f1)
let conv9 ty = let conv9 ty =
@ -735,7 +735,7 @@ module Binary = struct
read: 'a. 'a t -> MBytes.t -> int -> int -> (int * 'a) ; read: 'a. 'a t -> MBytes.t -> int -> int -> (int * 'a) ;
} }
let rec length : type x. x t -> x -> int = fun e -> let rec length : type x. x t -> x -> int = fun e ->
match e.encoding with match e.encoding with
(* Fixed *) (* Fixed *)
| Null -> fun _ -> 0 | Null -> fun _ -> 0
@ -1265,7 +1265,7 @@ let rec length : type x. x t -> x -> int = fun e ->
| P_seq : { path : path ; encoding : 'a t ; | P_seq : { path : path ; encoding : 'a t ;
fun_data_len : int -> int } -> path fun_data_len : int -> int } -> path
| P_list : { path:path ; encoding:'a t ; data_len : int ; | P_list : { path:path ; encoding:'a t ; data_len : int ;
base_ofs : int ; nb_elts_read : int } -> path base_ofs : int ; nb_elts_read : int } -> path
(* used to accumulate given mbytes when reading a list of blocks, (* used to accumulate given mbytes when reading a list of blocks,
as well as the current offset and the number of unread bytes *) as well as the current offset and the number of unread bytes *)
@ -1634,18 +1634,18 @@ let rec length : type x. x t -> x -> int = fun e ->
MBytes.t list -> 'a t -> MBytes.t list -> 'a t ->
(MBytes.t Queue.t -> int -> 'b option) -> 'b status (MBytes.t Queue.t -> int -> 'b option) -> 'b status
= fun l e success_result -> = fun l e success_result ->
match classify e with match classify e with
| `Variable -> invalid_arg "streaming data with variable size" | `Variable -> invalid_arg "streaming data with variable size"
| `Fixed _ | `Dynamic -> | `Fixed _ | `Dynamic ->
let mb_buf = { let mb_buf = {
past = Queue.create() ; past_len = 0 ; past = Queue.create() ; past_len = 0 ;
future = Queue.create() ; unread = 0; ofs = 0 } future = Queue.create() ; unread = 0; ofs = 0 }
in in
List.iter (insert_mbytes mb_buf) l ; List.iter (insert_mbytes mb_buf) l ;
let path = let path =
P_await { path = P_top ; encoding = e ; data_len = - 1 } in P_await { path = P_top ; encoding = e ; data_len = - 1 } in
try bytes_stream_reader_rec (data_checker path mb_buf) success_result try bytes_stream_reader_rec (data_checker path mb_buf) success_result
with _ -> Error with _ -> Error
end end

View File

@ -81,11 +81,11 @@ val unit : unit encoding
val constant : string -> unit encoding val constant : string -> unit encoding
(** Signed 8 bit integer (** Signed 8 bit integer
(data is encoded as a byte in binary and an integer in JSON). *) (data is encoded as a byte in binary and an integer in JSON). *)
val int8 : int encoding val int8 : int encoding
(** Unsigned 8 bit integer (** Unsigned 8 bit integer
(data is encoded as a byte in binary and an integer in JSON). *) (data is encoded as a byte in binary and an integer in JSON). *)
val uint8 : int encoding val uint8 : int encoding
(** Signed 16 bit integer (** Signed 16 bit integer
@ -93,7 +93,7 @@ val uint8 : int encoding
val int16 : int encoding val int16 : int encoding
(** Unsigned 16 bit integer (** Unsigned 16 bit integer
(data is encoded as a short in binary and an integer in JSON). *) (data is encoded as a short in binary and an integer in JSON). *)
val uint16 : int encoding val uint16 : int encoding
(** Signed 31 bit integer, which corresponds to type int on 32-bit OCaml systems (** Signed 31 bit integer, which corresponds to type int on 32-bit OCaml systems
@ -105,7 +105,7 @@ val int31 : int encoding
val int32 : int32 encoding val int32 : int32 encoding
(** Signed 64 bit integer (** Signed 64 bit integer
(data is encodedas a 64-bit int in binary and a decimal string in JSON). *) (data is encodedas a 64-bit int in binary and a decimal string in JSON). *)
val int64 : int64 encoding val int64 : int64 encoding
(** Encoding of a boolean (** Encoding of a boolean

View File

@ -111,12 +111,12 @@ let merge_filter_list2
| r1, [] -> finalize acc @ (filter_map (fun x1 -> f (Some x1) None) r1) | r1, [] -> finalize acc @ (filter_map (fun x1 -> f (Some x1) None) r1)
| [], r2 -> finalize acc @ (filter_map (fun x2 -> f None (Some x2)) r2) | [], r2 -> finalize acc @ (filter_map (fun x2 -> f None (Some x2)) r2)
| ((h1 :: t1) as r1), ((h2 :: t2) as r2) -> | ((h1 :: t1) as r1), ((h2 :: t2) as r2) ->
if compare h1 h2 > 0 then if compare h1 h2 > 0 then
merge_aux (may_cons acc (f None (Some h2))) (r1, t2) merge_aux (may_cons acc (f None (Some h2))) (r1, t2)
else if compare h1 h2 < 0 then else if compare h1 h2 < 0 then
merge_aux (may_cons acc (f (Some h1) None)) (t1, r2) merge_aux (may_cons acc (f (Some h1) None)) (t1, r2)
else (* m1 = m2 *) else (* m1 = m2 *)
merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2) merge_aux (may_cons acc (f (Some h1) (Some h2))) (t1, t2)
in in
merge_aux [] (sort l1, sort l2) merge_aux [] (sort l1, sort l2)
@ -149,9 +149,9 @@ let rec remove_elem_from_list nb = function
let split_list_at n l = let split_list_at n l =
let rec split n acc = function let rec split n acc = function
| [] -> List.rev acc, [] | [] -> List.rev acc, []
| l when n <= 0 -> List.rev acc, l | l when n <= 0 -> List.rev acc, l
| hd :: tl -> split (n - 1) (hd :: acc) tl in | hd :: tl -> split (n - 1) (hd :: acc) tl in
split n [] l split n [] l
let has_prefix ~prefix s = let has_prefix ~prefix s =

View File

@ -131,7 +131,7 @@ let commit ~time ~message context =
code dt code dt
end end
end >>= fun () -> end >>= fun () ->
Lwt.return commit Lwt.return commit
(*-- Generic Store Primitives ------------------------------------------------*) (*-- Generic Store Primitives ------------------------------------------------*)

View File

@ -162,18 +162,18 @@ module MakePersistentMap (S : STORE) (K : KEY) (C : VALUE)
OCaml map as an explicitly synchronized in-memory buffer. *) OCaml map as an explicitly synchronized in-memory buffer. *)
module MakeBufferedPersistentMap module MakeBufferedPersistentMap
(S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t) (S : STORE) (K : KEY) (C : VALUE) (Map : Map.S with type key = K.t)
: BUFFERED_PERSISTENT_MAP : BUFFERED_PERSISTENT_MAP
with type t := S.t with type t := S.t
and type key := K.t and type key := K.t
and type value := C.t and type value := C.t
and module Map := Map and module Map := Map
(** {2 Predefined Instances} *************************************************) (** {2 Predefined Instances} *************************************************)
module MakePersistentBytesMap (S : STORE) (K : KEY) module MakePersistentBytesMap (S : STORE) (K : KEY)
: PERSISTENT_MAP : PERSISTENT_MAP
with type t := S.t and type key := K.t and type value := MBytes.t with type t := S.t and type key := K.t and type value := MBytes.t
module MakeBufferedPersistentBytesMap module MakeBufferedPersistentBytesMap
(S : STORE) (K : KEY) (Map : Map.S with type key = K.t) (S : STORE) (K : KEY) (Map : Map.S with type key = K.t)

View File

@ -97,9 +97,9 @@ module Block = struct
let open Data_encoding in let open Data_encoding in
conv conv
(fun { header ; message ; max_operations_ttl ; context } -> (fun { header ; message ; max_operations_ttl ; context } ->
(message, max_operations_ttl, context, header)) (message, max_operations_ttl, context, header))
(fun (message, max_operations_ttl, context, header) -> (fun (message, max_operations_ttl, context, header) ->
{ header ; message ; max_operations_ttl ; context }) { header ; message ; max_operations_ttl ; context })
(obj4 (obj4
(req "message" string) (req "message" string)
(req "max_operations_ttl" uint16) (req "max_operations_ttl" uint16)

View File

@ -113,9 +113,9 @@ module Make_indexed_substore (S : STORE) (I : INDEX) = struct
| Some path -> f path acc | Some path -> f path acc
else else
S.fold t path ~init:acc ~f:begin fun k acc -> S.fold t path ~init:acc ~f:begin fun k acc ->
match k with match k with
| `Dir k -> dig (i-1) k acc | `Dir k -> dig (i-1) k acc
| `Key _ -> Lwt.return acc | `Key _ -> Lwt.return acc
end in end in
dig I.path_length [] init dig I.path_length [] init

View File

@ -26,8 +26,8 @@ module Make_set (S : STORE) (I : INDEX)
module Make_buffered_set module Make_buffered_set
(S : STORE) (I : INDEX) (Set : Set.S with type elt = I.t) (S : STORE) (I : INDEX) (Set : Set.S with type elt = I.t)
: BUFFERED_SET_STORE with type t = S.t : BUFFERED_SET_STORE with type t = S.t
and type elt = I.t and type elt = I.t
and module Set = Set and module Set = Set
module Make_map module Make_map
(S : STORE) (I : INDEX) (V : VALUE) (S : STORE) (I : INDEX) (V : VALUE)

View File

@ -30,8 +30,8 @@ let () =
~title: "Invalid data directory version" ~title: "Invalid data directory version"
~description: "The data directory version was not the one that was expected" ~description: "The data directory version was not the one that was expected"
Data_encoding.(obj2 Data_encoding.(obj2
(req "expectedVersion" string) (req "expectedVersion" string)
(req "actualVersion" string)) (req "actualVersion" string))
(function (function
| Invalid_data_dir_version (expected, actual) -> | Invalid_data_dir_version (expected, actual) ->
Some (expected, actual) Some (expected, actual)
@ -59,7 +59,7 @@ let () =
~pp:(fun ppf path -> ~pp:(fun ppf path ->
Format.fprintf ppf Format.fprintf ppf
"Expected to find data directory version file at '%s', \ "Expected to find data directory version file at '%s', \
\ but the file did not exist." \ but the file did not exist."
path) path)
(function No_data_dir_version_file path -> Some path | _ -> None) (function No_data_dir_version_file path -> Some path | _ -> None)
(fun path -> No_data_dir_version_file path) (fun path -> No_data_dir_version_file path)

View File

@ -115,25 +115,25 @@ let init_node ?sandbox (config : Node_config_file.t) =
| _ -> | _ ->
(Node_config_file.resolve_bootstrap_addrs (Node_config_file.resolve_bootstrap_addrs
config.net.bootstrap_peers) >>= fun trusted_points -> config.net.bootstrap_peers) >>= fun trusted_points ->
Node_identity_file.read Node_identity_file.read
(config.data_dir // (config.data_dir //
Node_identity_file.default_name) >>=? fun identity -> Node_identity_file.default_name) >>=? fun identity ->
lwt_log_notice lwt_log_notice
"Peer's global id: %a" "Peer's global id: %a"
P2p.Peer_id.pp identity.peer_id >>= fun () -> P2p.Peer_id.pp identity.peer_id >>= fun () ->
let p2p_config : P2p.config = let p2p_config : P2p.config =
{ listening_addr ; { listening_addr ;
listening_port ; listening_port ;
trusted_points ; trusted_points ;
peers_file = peers_file =
(config.data_dir // "peers.json") ; (config.data_dir // "peers.json") ;
closed_network = config.net.closed ; closed_network = config.net.closed ;
identity ; identity ;
proof_of_work_target = proof_of_work_target =
Crypto_box.make_target config.net.expected_pow ; Crypto_box.make_target config.net.expected_pow ;
} }
in in
return (Some (p2p_config, config.net.limits)) return (Some (p2p_config, config.net.limits))
end >>=? fun p2p_config -> end >>=? fun p2p_config ->
let node_config : Node.config = { let node_config : Node.config = {
genesis ; genesis ;

View File

@ -155,7 +155,7 @@ module Term = struct
let binary_chunks_size = let binary_chunks_size =
let doc = let doc =
Format.sprintf Format.sprintf
"Size limit (in kB) of binary blocks that are sent to other peers." "Size limit (in kB) of binary blocks that are sent to other peers."
in in
Arg.(value & opt (some int) None & Arg.(value & opt (some int) None &
info ~docs ~doc ~docv:"NUM" ["binary-chunks-size"]) info ~docs ~doc ~docv:"NUM" ["binary-chunks-size"])

View File

@ -226,10 +226,10 @@ module Real = struct
P2p_connection_pool.Connection.fold P2p_connection_pool.Connection.fold
net.pool ~init:[] net.pool ~init:[]
~f:begin fun _peer_id conn acc -> ~f:begin fun _peer_id conn acc ->
(P2p_connection_pool.is_readable conn >>= function (P2p_connection_pool.is_readable conn >>= function
| Ok () -> Lwt.return (Some conn) | Ok () -> Lwt.return (Some conn)
| Error _ -> Lwt_utils.never_ending) :: acc | Error _ -> Lwt_utils.never_ending) :: acc
end in end in
Lwt.pick ( Lwt.pick (
( P2p_connection_pool.Pool_event.wait_new_connection net.pool >>= fun () -> ( P2p_connection_pool.Pool_event.wait_new_connection net.pool >>= fun () ->
Lwt.return_none ):: Lwt.return_none )::

View File

@ -460,8 +460,8 @@ module GcPeer_idSet = Utils.Bounded(struct
end) end)
let gc_peer_ids ({ meta_config = { score } ; let gc_peer_ids ({ meta_config = { score } ;
config = { max_known_peer_ids } ; config = { max_known_peer_ids } ;
known_peer_ids ; } as pool) = known_peer_ids ; } as pool) =
match max_known_peer_ids with match max_known_peer_ids with
| None -> () | None -> ()
| Some (_, target) -> | Some (_, target) ->
@ -804,13 +804,13 @@ and authenticate pool ?point_info canceler fd point =
unopt_map connection_point_info unopt_map connection_point_info
~default:(not pool.config.closed_network) ~default:(not pool.config.closed_network)
~f:begin fun connection_point_info -> ~f:begin fun connection_point_info ->
match Point_info.State.get connection_point_info with match Point_info.State.get connection_point_info with
| Requested _ -> not incoming | Requested _ -> not incoming
| Disconnected -> | Disconnected ->
not pool.config.closed_network not pool.config.closed_network
|| Point_info.trusted connection_point_info || Point_info.trusted connection_point_info
| Accepted _ | Running _ -> false | Accepted _ | Running _ -> false
end end
in in
let acceptable_peer_id = let acceptable_peer_id =
match Peer_info.State.get peer_info with match Peer_info.State.get peer_info with
@ -975,7 +975,7 @@ and swap_request pool conn new_point _new_peer_id =
(Time.max pool.latest_succesfull_swap pool.latest_accepted_swap) in (Time.max pool.latest_succesfull_swap pool.latest_accepted_swap) in
let new_point_info = register_point pool source_peer_id new_point in let new_point_info = register_point pool source_peer_id new_point in
if span_since_last_swap < int_of_float pool.config.swap_linger if span_since_last_swap < int_of_float pool.config.swap_linger
|| not (Point_info.State.is_disconnected new_point_info) then begin || not (Point_info.State.is_disconnected new_point_info) then begin
log pool (Swap_request_ignored { source = source_peer_id }) ; log pool (Swap_request_ignored { source = source_peer_id }) ;
lwt_log_info "Ignoring swap request from %a" Peer_id.pp source_peer_id lwt_log_info "Ignoring swap request from %a" Peer_id.pp source_peer_id
end else begin end else begin
@ -1043,7 +1043,7 @@ let accept pool fd point =
log pool (Incoming_connection point) ; log pool (Incoming_connection point) ;
if pool.config.max_incoming_connections <= Point.Table.length pool.incoming if pool.config.max_incoming_connections <= Point.Table.length pool.incoming
|| pool.config.max_connections <= active_connections pool then || pool.config.max_connections <= active_connections pool then
Lwt.async (fun () -> Lwt_utils.safe_close fd) Lwt.async (fun () -> Lwt_utils.safe_close fd)
else else
let canceler = Canceler.create () in let canceler = Canceler.create () in
Point.Table.add pool.incoming point canceler ; Point.Table.add pool.incoming point canceler ;

View File

@ -367,26 +367,26 @@ module Peer_info = struct
let open Data_encoding in let open Data_encoding in
conv conv
(fun { peer_id ; trusted ; metadata ; events ; created ; (fun { peer_id ; trusted ; metadata ; events ; created ;
last_failed_connection ; last_rejected_connection ; last_failed_connection ; last_rejected_connection ;
last_established_connection ; last_disconnection } -> last_established_connection ; last_disconnection } ->
(peer_id, created, trusted, metadata, Ring.elements events, (peer_id, created, trusted, metadata, Ring.elements events,
last_failed_connection, last_rejected_connection, last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection)) last_established_connection, last_disconnection))
(fun (peer_id, created, trusted, metadata, event_list, (fun (peer_id, created, trusted, metadata, event_list,
last_failed_connection, last_rejected_connection, last_failed_connection, last_rejected_connection,
last_established_connection, last_disconnection) -> last_established_connection, last_disconnection) ->
let info = create ~trusted ~metadata peer_id in let info = create ~trusted ~metadata peer_id in
let events = Ring.create log_size in let events = Ring.create log_size in
Ring.add_list info.events event_list ; Ring.add_list info.events event_list ;
{ state = Disconnected ; { state = Disconnected ;
trusted ; peer_id ; metadata ; created ; trusted ; peer_id ; metadata ; created ;
last_failed_connection ; last_failed_connection ;
last_rejected_connection ; last_rejected_connection ;
last_established_connection ; last_established_connection ;
last_disconnection ; last_disconnection ;
events ; events ;
watchers = Watcher.create_input () ; watchers = Watcher.create_input () ;
}) })
(obj9 (obj9
(req "peer_id" Peer_id.encoding) (req "peer_id" Peer_id.encoding)
(req "created" Time.encoding) (req "created" Time.encoding)

View File

@ -76,15 +76,15 @@ module Point_info : sig
type 'conn t = type 'conn t =
| Requested of { cancel: Canceler.t } | Requested of { cancel: Canceler.t }
(** We initiated a connection. *) (** We initiated a connection. *)
| Accepted of { current_peer_id: Peer_id.t ; | Accepted of { current_peer_id: Peer_id.t ;
cancel: Canceler.t } cancel: Canceler.t }
(** We accepted a incoming connection. *) (** We accepted a incoming connection. *)
| Running of { data: 'conn ; | Running of { data: 'conn ;
current_peer_id: Peer_id.t } current_peer_id: Peer_id.t }
(** Successfully authentificated connection, normal business. *) (** Successfully authentificated connection, normal business. *)
| Disconnected | Disconnected
(** No connection established currently. *) (** No connection established currently. *)
type 'conn state = 'conn t type 'conn state = 'conn t
val pp : Format.formatter -> 'conn t -> unit val pp : Format.formatter -> 'conn t -> unit
@ -113,19 +113,19 @@ module Point_info : sig
type kind = type kind =
| Outgoing_request | Outgoing_request
(** We initiated a connection. *) (** We initiated a connection. *)
| Accepting_request of Peer_id.t | Accepting_request of Peer_id.t
(** We accepted a connection after authentifying the remote peer. *) (** We accepted a connection after authentifying the remote peer. *)
| Rejecting_request of Peer_id.t | Rejecting_request of Peer_id.t
(** We rejected a connection after authentifying the remote peer. *) (** We rejected a connection after authentifying the remote peer. *)
| Request_rejected of Peer_id.t option | Request_rejected of Peer_id.t option
(** The remote peer rejected our connection. *) (** The remote peer rejected our connection. *)
| Connection_established of Peer_id.t | Connection_established of Peer_id.t
(** We succesfully established a authentified connection. *) (** We succesfully established a authentified connection. *)
| Disconnection of Peer_id.t | Disconnection of Peer_id.t
(** We decided to close the connection. *) (** We decided to close the connection. *)
| External_disconnection of Peer_id.t | External_disconnection of Peer_id.t
(** The connection was closed for external reason. *) (** The connection was closed for external reason. *)
type t = { type t = {
kind : kind ; kind : kind ;
@ -207,13 +207,13 @@ module Peer_info : sig
type 'conn t = type 'conn t =
| Accepted of { current_point: Id_point.t ; | Accepted of { current_point: Id_point.t ;
cancel: Canceler.t } cancel: Canceler.t }
(** We accepted a incoming connection, we greeted back and (** We accepted a incoming connection, we greeted back and
we are waiting for an acknowledgement. *) we are waiting for an acknowledgement. *)
| Running of { data: 'conn ; | Running of { data: 'conn ;
current_point: Id_point.t } current_point: Id_point.t }
(** Successfully authentificated connection, normal business. *) (** Successfully authentificated connection, normal business. *)
| Disconnected | Disconnected
(** No connection established currently. *) (** No connection established currently. *)
type 'conn state = 'conn t type 'conn state = 'conn t
val pp : Format.formatter -> 'conn t -> unit val pp : Format.formatter -> 'conn t -> unit
@ -241,17 +241,17 @@ module Peer_info : sig
type kind = type kind =
| Accepting_request | Accepting_request
(** We accepted a connection after authentifying the remote peer. *) (** We accepted a connection after authentifying the remote peer. *)
| Rejecting_request | Rejecting_request
(** We rejected a connection after authentifying the remote peer. *) (** We rejected a connection after authentifying the remote peer. *)
| Request_rejected | Request_rejected
(** The remote peer rejected our connection. *) (** The remote peer rejected our connection. *)
| Connection_established | Connection_established
(** We succesfully established a authentified connection. *) (** We succesfully established a authentified connection. *)
| Disconnection | Disconnection
(** We decided to close the connection. *) (** We decided to close the connection. *)
| External_disconnection | External_disconnection
(** The connection was closed for external reason. *) (** The connection was closed for external reason. *)
type t = { type t = {
kind : kind ; kind : kind ;

View File

@ -206,7 +206,7 @@ module Scheduler(IO : IO) = struct
st.readys_low ; st.readys_low ;
Queue.clear st.readys_low ; Queue.clear st.readys_low ;
Queue.transfer tmp st.readys_low ; Queue.transfer tmp st.readys_low ;
end end
let shutdown st = let shutdown st =
lwt_debug "--> scheduler(%s).shutdown" IO.name >>= fun () -> lwt_debug "--> scheduler(%s).shutdown" IO.name >>= fun () ->
@ -349,42 +349,42 @@ let write_size mbytes =
let register = let register =
let cpt = ref 0 in let cpt = ref 0 in
fun st conn -> fun st conn ->
if st.closed then begin if st.closed then begin
Lwt.async (fun () -> Lwt_utils.safe_close conn) ; Lwt.async (fun () -> Lwt_utils.safe_close conn) ;
raise Closed raise Closed
end else begin end else begin
let id = incr cpt; !cpt in let id = incr cpt; !cpt in
let canceler = Canceler.create () in let canceler = Canceler.create () in
let read_size = let read_size =
map_option st.read_queue_size ~f:(fun v -> v, read_size) in map_option st.read_queue_size ~f:(fun v -> v, read_size) in
let write_size = let write_size =
map_option st.write_queue_size ~f:(fun v -> v, write_size) in map_option st.write_queue_size ~f:(fun v -> v, write_size) in
let read_queue = Lwt_pipe.create ?size:read_size () in let read_queue = Lwt_pipe.create ?size:read_size () in
let write_queue = Lwt_pipe.create ?size:write_size () in let write_queue = Lwt_pipe.create ?size:write_size () in
let read_conn = let read_conn =
ReadScheduler.create_connection ReadScheduler.create_connection
st.read_scheduler (conn, st.read_buffer_size) read_queue canceler id st.read_scheduler (conn, st.read_buffer_size) read_queue canceler id
and write_conn = and write_conn =
WriteScheduler.create_connection WriteScheduler.create_connection
st.write_scheduler write_queue conn canceler id in st.write_scheduler write_queue conn canceler id in
Canceler.on_cancel canceler begin fun () -> Canceler.on_cancel canceler begin fun () ->
Inttbl.remove st.connected id ; Inttbl.remove st.connected id ;
Moving_average.destroy read_conn.counter ; Moving_average.destroy read_conn.counter ;
Moving_average.destroy write_conn.counter ; Moving_average.destroy write_conn.counter ;
Lwt_pipe.close write_queue ; Lwt_pipe.close write_queue ;
Lwt_pipe.close read_queue ; Lwt_pipe.close read_queue ;
Lwt_utils.safe_close conn Lwt_utils.safe_close conn
end ; end ;
let conn = { let conn = {
sched = st ; id ; conn ; canceler ; sched = st ; id ; conn ; canceler ;
read_queue ; read_conn ; read_queue ; read_conn ;
write_queue ; write_conn ; write_queue ; write_conn ;
partial_read = None ; partial_read = None ;
} in } in
Inttbl.add st.connected id conn ; Inttbl.add st.connected id conn ;
log_info "--> register (%d)" conn.id ; log_info "--> register (%d)" conn.id ;
conn conn
end end
let write { write_queue } msg = let write { write_queue } msg =
Lwt.catch Lwt.catch

View File

@ -160,7 +160,7 @@ let rec worker_loop st =
end >>=? fun () -> end >>=? fun () ->
let n_connected = P2p_connection_pool.active_connections pool in let n_connected = P2p_connection_pool.active_connections pool in
if n_connected < st.bounds.min_threshold if n_connected < st.bounds.min_threshold
|| st.bounds.max_threshold < n_connected then || st.bounds.max_threshold < n_connected then
maintain st maintain st
else begin else begin
P2p_connection_pool.send_swap_request pool ; P2p_connection_pool.send_swap_request pool ;

View File

@ -95,8 +95,8 @@ module Identity : sig
val generate_with_animation : val generate_with_animation :
Format.formatter -> Crypto_box.target -> t Format.formatter -> Crypto_box.target -> t
(** [generate_with_animation ppf target] is a freshly minted identity (** [generate_with_animation ppf target] is a freshly minted identity
whose proof of work stamp difficulty is at least equal to [target]. *) whose proof of work stamp difficulty is at least equal to [target]. *)
end end

View File

@ -31,10 +31,10 @@ let compute (b: Block.t) sz =
| Some predecessor -> | Some predecessor ->
if cpt = 0 then if cpt = 0 then
loop (Block.hash b :: acc) (sz - 1) loop (Block.hash b :: acc) (sz - 1)
(step * 2) (step * 20 - 1) predecessor (step * 2) (step * 20 - 1) predecessor
else if cpt mod step = 0 then else if cpt mod step = 0 then
loop (Block.hash b :: acc) (sz - 1) loop (Block.hash b :: acc) (sz - 1)
step (cpt - 1) predecessor step (cpt - 1) predecessor
else else
loop acc sz step (cpt - 1) predecessor in loop acc sz step (cpt - 1) predecessor in
Block.predecessor b >>= function Block.predecessor b >>= function
@ -78,8 +78,8 @@ type step = {
let to_steps locator = let to_steps locator =
fold fold
~f:begin fun acc ~block ~pred ~step ~strict_step -> { ~f:begin fun acc ~block ~pred ~step ~strict_step -> {
block ; predecessor = pred ; step ; strict_step ; block ; predecessor = pred ; step ; strict_step ;
} :: acc } :: acc
end end
[] locator [] locator

View File

@ -49,4 +49,4 @@ val live_blocks:
[blocks] is the set of arity [n], that contains [b] and its [n-1] [blocks] is the set of arity [n], that contains [b] and its [n-1]
predecessors. And where [operations] is the set of operations predecessors. And where [operations] is the set of operations
included in those blocks. included in those blocks.
*) *)

View File

@ -25,7 +25,7 @@ module Make_raw
val name : string val name : string
val encoding : t Data_encoding.t val encoding : t Data_encoding.t
val pp : Format.formatter -> t -> unit val pp : Format.formatter -> t -> unit
end) end)
(Disk_table : (Disk_table :
Distributed_db_functors.DISK_TABLE with type key := Hash.t) Distributed_db_functors.DISK_TABLE with type key := Hash.t)
(Memory_table : (Memory_table :
@ -329,10 +329,10 @@ and p2p_reader = {
} }
let noop_callback = { let noop_callback = {
notify_branch = begin fun _gid _locator -> () end ; notify_branch = begin fun _gid _locator -> () end ;
notify_head = begin fun _gid _block _ops -> () end ; notify_head = begin fun _gid _block _ops -> () end ;
disconnection = begin fun _gid -> () end ; disconnection = begin fun _gid -> () end ;
} }
type t = db type t = db
@ -566,7 +566,7 @@ module P2p_reader = struct
| None -> Lwt.return_unit | None -> Lwt.return_unit
| Some bh -> | Some bh ->
if Operation_list_list_hash.compare if Operation_list_list_hash.compare
found_hash bh.shell.operations_hash <> 0 then found_hash bh.shell.operations_hash <> 0 then
Lwt.return_unit Lwt.return_unit
else else
Raw_operations.Table.notify Raw_operations.Table.notify
@ -671,9 +671,9 @@ let activate ({ p2p ; active_nets } as global_db) net_state =
active_connections = P2p.Peer_id.Table.create 53 ; active_connections = P2p.Peer_id.Table.create 53 ;
} in } in
P2p.iter_connections p2p (fun _peer_id conn -> P2p.iter_connections p2p (fun _peer_id conn ->
Lwt.async begin fun () -> Lwt.async begin fun () ->
P2p.send p2p conn (Get_current_branch net_id) P2p.send p2p conn (Get_current_branch net_id)
end) ; end) ;
Net_id.Table.add active_nets net_id net ; Net_id.Table.add active_nets net_id net ;
net net
| net -> | net ->
@ -695,7 +695,7 @@ let deactivate net_db =
net_db.active_connections ; net_db.active_connections ;
Raw_operation.shutdown net_db.operation_db >>= fun () -> Raw_operation.shutdown net_db.operation_db >>= fun () ->
Raw_block_header.shutdown net_db.block_header_db >>= fun () -> Raw_block_header.shutdown net_db.block_header_db >>= fun () ->
Lwt.return_unit >>= fun () -> Lwt.return_unit >>= fun () ->
Lwt.return_unit Lwt.return_unit
let get_net { active_nets } net_id = let get_net { active_nets } net_id =
@ -715,9 +715,9 @@ let shutdown { p2p ; p2p_readers ; active_nets } =
Lwt.return_unit >>= fun () -> Lwt.return_unit >>= fun () ->
Net_id.Table.fold Net_id.Table.fold
(fun _ net_db acc -> (fun _ net_db acc ->
Raw_operation.shutdown net_db.operation_db >>= fun () -> Raw_operation.shutdown net_db.operation_db >>= fun () ->
Raw_block_header.shutdown net_db.block_header_db >>= fun () -> Raw_block_header.shutdown net_db.block_header_db >>= fun () ->
acc) acc)
active_nets active_nets
Lwt.return_unit >>= fun () -> Lwt.return_unit >>= fun () ->
P2p.shutdown p2p >>= fun () -> P2p.shutdown p2p >>= fun () ->

View File

@ -259,7 +259,7 @@ end = struct
~f:(fun input -> Watcher.notify input (k, v)) ; ~f:(fun input -> Watcher.notify input (k, v)) ;
Watcher.notify s.input (k, v) ; Watcher.notify s.input (k, v) ;
Lwt.return_unit Lwt.return_unit
end end
| Found _ -> | Found _ ->
Scheduler.notify_duplicate s.scheduler p k ; Scheduler.notify_duplicate s.scheduler p k ;
Lwt.return_unit Lwt.return_unit

View File

@ -150,7 +150,7 @@ module RPC = struct
operations: Operation_hash.t list list option ; operations: Operation_hash.t list list option ;
protocol: Protocol_hash.t ; protocol: Protocol_hash.t ;
test_network: Context.test_network; test_network: Context.test_network;
} }
let convert (block: State.Block.t) = let convert (block: State.Block.t) =
let hash = State.Block.hash block in let hash = State.Block.hash block in
@ -363,7 +363,7 @@ module RPC = struct
operations = begin fun () -> operations = begin fun () ->
Lwt_list.map_p Lwt_list.map_p
(Lwt_list.map_p (Lwt_list.map_p
(Distributed_db.Operation.read_exn net_db)) (Distributed_db.Operation.read_exn net_db))
operation_hashes operation_hashes
end ; end ;
context ; context ;

View File

@ -26,17 +26,17 @@ let monitor_operations node contents =
| None -> Lwt.return_none | None -> Lwt.return_none
| Some (h, op) when contents -> Lwt.return (Some [[h, Some op]]) | Some (h, op) when contents -> Lwt.return (Some [[h, Some op]])
| Some (h, _) -> Lwt.return (Some [[h, None]]) | Some (h, _) -> Lwt.return (Some [[h, None]])
else begin else begin
first_request := false ; first_request := false ;
Node.RPC.operation_hashes node `Prevalidation >>= fun hashes -> Node.RPC.operation_hashes node `Prevalidation >>= fun hashes ->
if contents then if contents then
Node.RPC.operations node `Prevalidation >>= fun ops -> Node.RPC.operations node `Prevalidation >>= fun ops ->
Lwt.return_some @@ Lwt.return_some @@
List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops
else else
Lwt.return_some @@ Lwt.return_some @@
List.map (List.map (fun h -> h, None)) hashes List.map (List.map (fun h -> h, None)) hashes
end in end in
RPC.Answer.return_stream { next ; shutdown } RPC.Answer.return_stream { next ; shutdown }
let register_bi_dir node dir = let register_bi_dir node dir =
@ -178,7 +178,7 @@ let create_delayed_stream
future_blocks := rest ; future_blocks := rest ;
future_blocks_set := future_blocks_set :=
Block_hash.Set.remove bi.hash !future_blocks_set ; Block_hash.Set.remove bi.hash !future_blocks_set ;
Some bi Some bi
| _ -> None in | _ -> None in
next, mem, insert, pop in next, mem, insert, pop in
let _block_watcher_worker = let _block_watcher_worker =
@ -275,7 +275,7 @@ let list_blocks
| Some time -> | Some time ->
let rec current_predecessor (bi: Node.RPC.block_info) = let rec current_predecessor (bi: Node.RPC.block_info) =
if Time.compare bi.timestamp time <= 0 if Time.compare bi.timestamp time <= 0
|| bi.hash = bi.predecessor then || bi.hash = bi.predecessor then
Lwt.return bi Lwt.return bi
else else
Node.RPC.raw_block_info node bi.predecessor >>= Node.RPC.raw_block_info node bi.predecessor >>=
@ -287,7 +287,7 @@ let list_blocks
(fun (fun
(bi1: Services.Blocks.block_info) (bi1: Services.Blocks.block_info)
(bi2: Services.Blocks.block_info) -> (bi2: Services.Blocks.block_info) ->
~- (Fitness.compare bi1.fitness bi2.fitness)) ~- (Fitness.compare bi1.fitness bi2.fitness))
heads_info in heads_info in
List.map List.map
(fun ({ hash } : Services.Blocks.block_info) -> hash) (fun ({ hash } : Services.Blocks.block_info) -> hash)
@ -453,7 +453,7 @@ let build_rpc_directory node =
let stream, stopper = Node.RPC.Network.watch node in let stream, stopper = Node.RPC.Network.watch node in
let shutdown () = Watcher.shutdown stopper in let shutdown () = Watcher.shutdown stopper in
let next () = Lwt_stream.get stream in let next () = Lwt_stream.get stream in
RPC.Answer.return_stream { next ; shutdown } in RPC.Answer.return_stream { next ; shutdown } in
RPC.register0 dir Services.Network.events implementation in RPC.register0 dir Services.Network.events implementation in
let dir = let dir =
let implementation point timeout = let implementation point timeout =
@ -500,7 +500,7 @@ let build_rpc_directory node =
end in end in
RPC.Answer.return_stream { next ; shutdown } RPC.Answer.return_stream { next ; shutdown }
else else
Node.RPC.Network.Peer_id.events node peer_id |> RPC.Answer.return in Node.RPC.Network.Peer_id.events node peer_id |> RPC.Answer.return in
RPC.register1 dir Services.Network.Peer_id.events implementation in RPC.register1 dir Services.Network.Peer_id.events implementation in
(* Network : Point *) (* Network : Point *)

View File

@ -25,7 +25,7 @@ module Error = struct
(Printf.sprintf (Printf.sprintf
"The full list of error is available with \ "The full list of error is available with \
the global RPC `%s /%s`" the global RPC `%s /%s`"
(RPC.string_of_method meth) (String.concat "/" path)) (RPC.string_of_method meth) (String.concat "/" path))
(conv (conv
~schema:Json_schema.any ~schema:Json_schema.any
(fun exn -> `A (List.map json_of_error exn)) (fun exn -> `A (List.map json_of_error exn))
@ -68,7 +68,7 @@ module Blocks = struct
| `Head of int | `Prevalidation | `Head of int | `Prevalidation
| `Test_head of int | `Test_prevalidation | `Test_head of int | `Test_prevalidation
| `Hash of Block_hash.t | `Hash of Block_hash.t
] ]
type block_info = { type block_info = {
hash: Block_hash.t ; hash: Block_hash.t ;
@ -367,8 +367,8 @@ module Blocks = struct
(include_ops, length, heads, monitor, delay, min_date, min_heads)) (include_ops, length, heads, monitor, delay, min_date, min_heads))
(fun (include_ops, length, heads, monitor, (fun (include_ops, length, heads, monitor,
delay, min_date, min_heads) -> delay, min_date, min_heads) ->
{ include_ops ; length ; heads ; monitor ; { include_ops ; length ; heads ; monitor ;
delay ; min_date ; min_heads }) delay ; min_date ; min_heads })
(obj7 (obj7
(dft "include_ops" (dft "include_ops"
(Data_encoding.describe (Data_encoding.describe

View File

@ -26,7 +26,7 @@ module Blocks : sig
| `Head of int | `Prevalidation | `Head of int | `Prevalidation
| `Test_head of int | `Test_prevalidation | `Test_head of int | `Test_prevalidation
| `Hash of Block_hash.t | `Hash of Block_hash.t
] ]
val blocks_arg : block RPC.Arg.arg val blocks_arg : block RPC.Arg.arg
val parse_block: string -> (block, string) result val parse_block: string -> (block, string) result

View File

@ -78,7 +78,7 @@ let create net_db =
Chain_traversal.live_blocks Chain_traversal.live_blocks
!head !head
(State.Block.max_operations_ttl !head) (State.Block.max_operations_ttl !head)
>>= fun (live_blocks, live_operations) -> >>= fun (live_blocks, live_operations) ->
let live_blocks = ref live_blocks in let live_blocks = ref live_blocks in
let live_operations = ref live_operations in let live_operations = ref live_operations in
let running_validation = ref Lwt.return_unit in let running_validation = ref Lwt.return_unit in

View File

@ -38,7 +38,7 @@ let () =
(function Bad_data_dir -> Some () | _ -> None) (function Bad_data_dir -> Some () | _ -> None)
(fun () -> Bad_data_dir) ; (fun () -> Bad_data_dir) ;
(** *) (** *)
module Shared = struct module Shared = struct
type 'a t = { type 'a t = {
@ -689,10 +689,10 @@ module Register_embedded_protocol
end end
let read let read
?patch_context ?patch_context
~store_root ~store_root
~context_root ~context_root
() = () =
Store.init store_root >>=? fun global_store -> Store.init store_root >>=? fun global_store ->
Context.init ?patch_context ~root:context_root >>= fun context_index -> Context.init ?patch_context ~root:context_root >>= fun context_index ->
let global_data = { let global_data = {

View File

@ -146,17 +146,17 @@ let rec may_set_head v (block: State.Block.t) =
(** Block validation *) (** Block validation *)
type error += type error +=
| Invalid_operation of Operation_hash.t | Invalid_operation of Operation_hash.t
| Invalid_fitness of { block: Block_hash.t ; | Invalid_fitness of { block: Block_hash.t ;
expected: Fitness.t ; expected: Fitness.t ;
found: Fitness.t } found: Fitness.t }
| Unknown_protocol | Unknown_protocol
| Non_increasing_timestamp | Non_increasing_timestamp
| Non_increasing_fitness | Non_increasing_fitness
| Wrong_level of Int32.t * Int32.t | Wrong_level of Int32.t * Int32.t
| Wrong_proto_level of int * int | Wrong_proto_level of int * int
| Replayed_operation of Operation_hash.t | Replayed_operation of Operation_hash.t
| Outdated_operation of Operation_hash.t * Block_hash.t | Outdated_operation of Operation_hash.t * Block_hash.t
let () = let () =
Error_monad.register_error_kind Error_monad.register_error_kind
@ -168,7 +168,7 @@ let () =
~pp:(fun ppf (block, expected, found) -> ~pp:(fun ppf (block, expected, found) ->
Format.fprintf ppf Format.fprintf ppf
"@[<v 2>Invalid fitness for block %a@ \ "@[<v 2>Invalid fitness for block %a@ \
\ expected %a@ \ \ expected %a@ \
\ found %a" \ found %a"
Block_hash.pp_short block Block_hash.pp_short block
Fitness.pp expected Fitness.pp expected
@ -365,110 +365,110 @@ let apply_block net_state db
module Context_db = struct module Context_db = struct
type data = type data =
{ validator: net_validator ; { validator: net_validator ;
state: [ `Inited of Block_header.t tzresult state: [ `Inited of Block_header.t tzresult
| `Initing of Block_header.t tzresult Lwt.t | `Initing of Block_header.t tzresult Lwt.t
| `Running of State.Block.t tzresult Lwt.t ] ; | `Running of State.Block.t tzresult Lwt.t ] ;
wakener: State.Block.t tzresult Lwt.u } wakener: State.Block.t tzresult Lwt.u }
type context = type context =
{ tbl : data Block_hash.Table.t ; { tbl : data Block_hash.Table.t ;
canceler : Lwt_utils.Canceler.t ; canceler : Lwt_utils.Canceler.t ;
worker_trigger: unit -> unit; worker_trigger: unit -> unit;
worker_waiter: unit -> unit Lwt.t ; worker_waiter: unit -> unit Lwt.t ;
worker: unit Lwt.t ; worker: unit Lwt.t ;
net_db : Distributed_db.net_db ; net_db : Distributed_db.net_db ;
net_state : State.Net.t } net_state : State.Net.t }
let pending_requests { tbl } = let pending_requests { tbl } =
Block_hash.Table.fold Block_hash.Table.fold
(fun h data acc -> (fun h data acc ->
match data.state with match data.state with
| `Initing _ -> acc | `Initing _ -> acc
| `Running _ -> acc | `Running _ -> acc
| `Inited d -> (h, d, data) :: acc) | `Inited d -> (h, d, data) :: acc)
tbl [] tbl []
let pending { tbl } hash = Block_hash.Table.mem tbl hash let pending { tbl } hash = Block_hash.Table.mem tbl hash
let request validator { tbl ; worker_trigger ; net_db } hash = let request validator { tbl ; worker_trigger ; net_db } hash =
assert (not (Block_hash.Table.mem tbl hash)); assert (not (Block_hash.Table.mem tbl hash));
let waiter, wakener = Lwt.wait () in let waiter, wakener = Lwt.wait () in
let data = let data =
Distributed_db.Block_header.fetch net_db hash () in Distributed_db.Block_header.fetch net_db hash () in
match Lwt.state data with match Lwt.state data with
| Lwt.Return data -> | Lwt.Return data ->
let state = `Inited data in let state = `Inited data in
Block_hash.Table.add tbl hash { validator ; state ; wakener } ; Block_hash.Table.add tbl hash { validator ; state ; wakener } ;
worker_trigger () ; worker_trigger () ;
waiter waiter
| _ -> | _ ->
let state = `Initing data in let state = `Initing data in
Block_hash.Table.add tbl hash { validator ; state ; wakener } ; Block_hash.Table.add tbl hash { validator ; state ; wakener } ;
Lwt.async Lwt.async
(fun () -> (fun () ->
data >>= fun data -> data >>= fun data ->
let state = `Inited data in let state = `Inited data in
Block_hash.Table.replace tbl hash { validator ; state ; wakener } ; Block_hash.Table.replace tbl hash { validator ; state ; wakener } ;
worker_trigger () ; worker_trigger () ;
Lwt.return_unit) ; Lwt.return_unit) ;
waiter waiter
let prefetch validator ({ net_state ; tbl } as session) hash = let prefetch validator ({ net_state ; tbl } as session) hash =
Lwt.ignore_result Lwt.ignore_result
(State.Block.known_valid net_state hash >>= fun exists -> (State.Block.known_valid net_state hash >>= fun exists ->
if not exists && not (Block_hash.Table.mem tbl hash) then if not exists && not (Block_hash.Table.mem tbl hash) then
request validator session hash >>= fun _ -> Lwt.return_unit request validator session hash >>= fun _ -> Lwt.return_unit
else else
Lwt.return_unit) Lwt.return_unit)
let known { net_state } hash = let known { net_state } hash =
State.Block.known_valid net_state hash State.Block.known_valid net_state hash
let read { net_state } hash = let read { net_state } hash =
State.Block.read net_state hash State.Block.read net_state hash
let fetch ({ net_state ; tbl } as session) validator hash = let fetch ({ net_state ; tbl } as session) validator hash =
try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener
with Not_found -> with Not_found ->
State.Block.known_invalid net_state hash >>= fun known_invalid -> State.Block.known_invalid net_state hash >>= fun known_invalid ->
if known_invalid then if known_invalid then
Lwt.return (Error [failure "Invalid predecessor"]) Lwt.return (Error [failure "Invalid predecessor"])
else else
State.Block.read_opt net_state hash >>= function State.Block.read_opt net_state hash >>= function
| Some op -> | Some op ->
Lwt.return (Ok op) Lwt.return (Ok op)
| None ->
try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener
with Not_found -> request validator session hash
let store { net_db ; tbl } hash data =
begin
match data with
| Ok data -> begin
Distributed_db.commit_block net_db hash data >>=? function
| None -> | None ->
try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener (* Should not happen if the block is not validated twice *)
with Not_found -> request validator session hash assert false
| Some block ->
let store { net_db ; tbl } hash data = return (Ok block)
begin end
match data with | Error err ->
| Ok data -> begin Distributed_db.commit_invalid_block net_db hash >>=? fun changed ->
Distributed_db.commit_block net_db hash data >>=? function assert changed ;
| None -> return (Error err)
(* Should not happen if the block is not validated twice *) end >>= function
assert false | Ok block ->
| Some block -> let wakener = (Block_hash.Table.find tbl hash).wakener in
return (Ok block) Block_hash.Table.remove tbl hash;
end Lwt.wakeup wakener block ;
| Error err -> Lwt.return_unit
Distributed_db.commit_invalid_block net_db hash >>=? fun changed -> | Error _ as err ->
assert changed ; let wakener = (Block_hash.Table.find tbl hash).wakener in
return (Error err) Block_hash.Table.remove tbl hash;
end >>= function Lwt.wakeup wakener err ;
| Ok block -> Lwt.return_unit
let wakener = (Block_hash.Table.find tbl hash).wakener in
Block_hash.Table.remove tbl hash;
Lwt.wakeup wakener block ;
Lwt.return_unit
| Error _ as err ->
let wakener = (Block_hash.Table.find tbl hash).wakener in
Block_hash.Table.remove tbl hash;
Lwt.wakeup wakener err ;
Lwt.return_unit
let process (v: net_validator) ~get_context ~set_context hash block = let process (v: net_validator) ~get_context ~set_context hash block =
let net_state = Distributed_db.net_state v.net_db in let net_state = Distributed_db.net_state v.net_db in
@ -482,7 +482,7 @@ module Context_db = struct
begin begin
Chain.genesis net_state >>= fun genesis -> Chain.genesis net_state >>= fun genesis ->
if Block_hash.equal (State.Block.hash genesis) if Block_hash.equal (State.Block.hash genesis)
block.shell.predecessor then block.shell.predecessor then
Lwt.return genesis Lwt.return genesis
else else
State.Block.read_exn net_state block.shell.predecessor State.Block.read_exn net_state block.shell.predecessor
@ -524,38 +524,38 @@ module Context_db = struct
return block return block
let request session ~get_context ~set_context pendings = let request session ~get_context ~set_context pendings =
let time = Time.now () in let time = Time.now () in
let min_block b pb = let min_block b pb =
match pb with match pb with
| None -> Some b | None -> Some b
| Some pb | Some pb
when b.Block_header.shell.timestamp when b.Block_header.shell.timestamp
< pb.Block_header.shell.timestamp -> < pb.Block_header.shell.timestamp ->
Some b Some b
| Some _ as pb -> pb in | Some _ as pb -> pb in
let next = let next =
List.fold_left List.fold_left
(fun acc (hash, block, (data : data)) -> (fun acc (hash, block, (data : data)) ->
match block with match block with
| Error _ -> | Error _ ->
acc
| Ok block ->
if Time.(block.Block_header.shell.timestamp > time) then
min_block block acc
else begin
Block_hash.Table.replace session.tbl hash { data with state = `Running begin
Lwt_main.yield () >>= fun () ->
process data.validator ~get_context ~set_context hash block >>= fun res ->
Block_hash.Table.remove session.tbl hash ;
Lwt.return res
end } ;
acc acc
| Ok block -> end)
if Time.(block.Block_header.shell.timestamp > time) then None
min_block block acc pendings in
else begin match next with
Block_hash.Table.replace session.tbl hash { data with state = `Running begin | None -> 0.
Lwt_main.yield () >>= fun () -> | Some b -> Int64.to_float (Time.diff b.Block_header.shell.timestamp time)
process data.validator ~get_context ~set_context hash block >>= fun res ->
Block_hash.Table.remove session.tbl hash ;
Lwt.return res
end } ;
acc
end)
None
pendings in
match next with
| None -> 0.
| Some b -> Int64.to_float (Time.diff b.Block_header.shell.timestamp time)
let create net_db = let create net_db =
let net_state = Distributed_db.net_state net_db in let net_state = Distributed_db.net_state net_db in
@ -649,7 +649,7 @@ let create_validator ?parent worker ?max_child_ttl state db net =
( Lwt_unix.sleep 30. >|= fun () -> None) ] >>= function ( Lwt_unix.sleep 30. >|= fun () -> None) ] >>= function
| Some block when | Some block when
Time.((State.Block.header block).shell.timestamp < add (Time.now ()) (-60L)) -> Time.((State.Block.header block).shell.timestamp < add (Time.now ()) (-60L)) ->
wait () wait ()
| _ -> | _ ->
Chain.head net >>= fun head -> Chain.head net >>= fun head ->
Chain.genesis net >>= fun genesis -> Chain.genesis net >>= fun genesis ->
@ -891,7 +891,7 @@ let create state db =
fetch_block net hash fetch_block net hash
else else
failwith "Fitness is below the current one" failwith "Fitness is below the current one"
end in end in
return (hash, validation) in return (hash, validation) in
let rec activate ?parent ?max_child_ttl net = let rec activate ?parent ?max_child_ttl net =

View File

@ -17,8 +17,8 @@ val notify_block: t -> Block_hash.t -> Block_header.t -> unit Lwt.t
type net_validator type net_validator
type error += type error +=
| Non_increasing_timestamp | Non_increasing_timestamp
| Non_increasing_fitness | Non_increasing_fitness
val activate: t -> ?max_child_ttl:int -> State.Net.t -> net_validator Lwt.t val activate: t -> ?max_child_ttl:int -> State.Net.t -> net_validator Lwt.t
val get: t -> Net_id.t -> net_validator tzresult Lwt.t val get: t -> Net_id.t -> net_validator tzresult Lwt.t

View File

@ -118,4 +118,4 @@ module LiftProtocol(Name : sig val name: string end)
(Env : Node_protocol_environment_sigs.V1) (Env : Node_protocol_environment_sigs.V1)
(P : Env.Updater.PROTOCOL) : (P : Env.Updater.PROTOCOL) :
NODE_PROTOCOL with type operation := P.operation NODE_PROTOCOL with type operation := P.operation
and type validation_state := P.validation_state and type validation_state := P.validation_state

View File

@ -38,7 +38,7 @@ let check_approval_and_update_quorum ctxt =
let updated_quorum = let updated_quorum =
Int32.div Int32.div
(Int32.add (Int32.mul 8l expected_quorum) (Int32.add (Int32.mul 8l expected_quorum)
(Int32.mul 2l actual_quorum)) (Int32.mul 2l actual_quorum))
10l in 10l in
Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt -> Vote.set_current_quorum ctxt updated_quorum >>=? fun ctxt ->
return return

View File

@ -189,9 +189,9 @@ let apply_sourced_operation
let delegate = Ed25519.Public_key.hash source in let delegate = Ed25519.Public_key.hash source in
check_signature_and_update_public_key check_signature_and_update_public_key
ctxt delegate (Some source) operation >>=? fun ctxt -> ctxt delegate (Some source) operation >>=? fun ctxt ->
(* TODO, see how to extract the public key hash after this operation to (* TODO, see how to extract the public key hash after this operation to
pass it to apply_delegate_operation_content *) pass it to apply_delegate_operation_content *)
fold_left_s (fun ctxt content -> fold_left_s (fun ctxt content ->
apply_delegate_operation_content apply_delegate_operation_content
ctxt delegate pred_block block_prio content) ctxt delegate pred_block block_prio content)
ctxt contents >>=? fun ctxt -> ctxt contents >>=? fun ctxt ->

View File

@ -26,8 +26,8 @@ let () =
~description:"The block timestamp is before the first slot \ ~description:"The block timestamp is before the first slot \
for this baker at this level" for this baker at this level"
~pp:(fun ppf (r, p) -> ~pp:(fun ppf (r, p) ->
Format.fprintf ppf "Block forged too early (%a is before %a)" Format.fprintf ppf "Block forged too early (%a is before %a)"
Time.pp_hum p Time.pp_hum r) Time.pp_hum p Time.pp_hum r)
Data_encoding.(obj2 Data_encoding.(obj2
(req "minimum" Time.encoding) (req "minimum" Time.encoding)
(req "provided" Time.encoding)) (req "provided" Time.encoding))
@ -102,12 +102,12 @@ let minimal_time c priority pred_timestamp =
else match durations with else match durations with
| [] -> cumsum_slot_durations acc [ Period.one_minute ] p | [] -> cumsum_slot_durations acc [ Period.one_minute ] p
| [ last ] -> | [ last ] ->
Period.mult p last >>? fun period -> Period.mult p last >>? fun period ->
Timestamp.(acc +? period) Timestamp.(acc +? period)
| first :: durations -> | first :: durations ->
Timestamp.(acc +? first) >>? fun acc -> Timestamp.(acc +? first) >>? fun acc ->
let p = Int32.pred p in let p = Int32.pred p in
cumsum_slot_durations acc durations p in cumsum_slot_durations acc durations p in
Lwt.return Lwt.return
(cumsum_slot_durations (cumsum_slot_durations
pred_timestamp (Constants.slot_durations c) (Int32.succ priority)) pred_timestamp (Constants.slot_durations c) (Int32.succ priority))

View File

@ -40,10 +40,10 @@ let proto_header_encoding =
(fun (priority, seed_nonce_hash, proof_of_work_nonce) -> (fun (priority, seed_nonce_hash, proof_of_work_nonce) ->
{ priority ; seed_nonce_hash ; proof_of_work_nonce }) { priority ; seed_nonce_hash ; proof_of_work_nonce })
(obj3 (obj3
(req "priority" uint16) (req "priority" uint16)
(req "seed_nonce_hash" Nonce_hash.encoding) (req "seed_nonce_hash" Nonce_hash.encoding)
(req "proof_of_work_nonce" (req "proof_of_work_nonce"
(Fixed.bytes Constants_repr.proof_of_work_nonce_size))) (Fixed.bytes Constants_repr.proof_of_work_nonce_size)))
let signed_proto_header_encoding = let signed_proto_header_encoding =
let open Data_encoding in let open Data_encoding in

View File

@ -164,20 +164,20 @@ let constants_encoding =
dictator_pubkey = dictator_pubkey =
unopt default.dictator_pubkey dictator_pubkey ; unopt default.dictator_pubkey dictator_pubkey ;
} ) } )
Data_encoding.( Data_encoding.(
merge_objs merge_objs
(obj10 (obj10
(opt "cycle_length" int32) (opt "cycle_length" int32)
(opt "voting_period_length" int32) (opt "voting_period_length" int32)
(opt "time_before_reward" int64) (opt "time_before_reward" int64)
(opt "slot_durations" (list Period_repr.encoding)) (opt "slot_durations" (list Period_repr.encoding))
(opt "first_free_baking_slot" uint16) (opt "first_free_baking_slot" uint16)
(opt "max_signing_slot" uint16) (opt "max_signing_slot" uint16)
(opt "instructions_per_transaction" int31) (opt "instructions_per_transaction" int31)
(opt "proof_of_work_threshold" int64) (opt "proof_of_work_threshold" int64)
(opt "bootstrap_keys" (list Ed25519.Public_key.encoding)) (opt "bootstrap_keys" (list Ed25519.Public_key.encoding))
(opt "dictator_pubkey" Ed25519.Public_key.encoding)) (opt "dictator_pubkey" Ed25519.Public_key.encoding))
unit) unit)
type error += Constant_read of exn type error += Constant_read of exn

View File

@ -12,17 +12,17 @@ type cycle = t
let encoding = Data_encoding.int32 let encoding = Data_encoding.int32
let arg = let arg =
let construct = Int32.to_string in let construct = Int32.to_string in
let destruct str = let destruct str =
match Int32.of_string str with match Int32.of_string str with
| exception _ -> Error "Cannot parse cycle" | exception _ -> Error "Cannot parse cycle"
| cycle -> Ok cycle in | cycle -> Ok cycle in
RPC.Arg.make RPC.Arg.make
~descr:"A cycle integer" ~descr:"A cycle integer"
~name: "block_cycle" ~name: "block_cycle"
~construct ~construct
~destruct ~destruct
() ()
let pp ppf cycle = Format.fprintf ppf "%ld" cycle let pp ppf cycle = Format.fprintf ppf "%ld" cycle

View File

@ -42,7 +42,7 @@ let encoding =
voting_period, voting_period_position) -> voting_period, voting_period_position) ->
{ level ; level_position ; { level ; level_position ;
cycle ; cycle_position ; cycle ; cycle_position ;
voting_period ; voting_period_position }) voting_period ; voting_period_position })
(obj6 (obj6
(req "level" Raw_level_repr.encoding) (req "level" Raw_level_repr.encoding)
(req "level_position" int32) (req "level_position" int32)

View File

@ -78,7 +78,7 @@ let begin_construction
~timestamp ~timestamp
?proto_header ?proto_header
() = () =
let level = Int32.succ pred_level in let level = Int32.succ pred_level in
let fitness = pred_fitness in let fitness = pred_fitness in
Tezos_context.init ~timestamp ~level ~fitness ctxt >>=? fun ctxt -> Tezos_context.init ~timestamp ~level ~fitness ctxt >>=? fun ctxt ->
begin begin

View File

@ -36,8 +36,8 @@ let get_unrevealed c level =
return (nonce_hash, delegate_to_reward, reward_amount) return (nonce_hash, delegate_to_reward, reward_amount)
(* let get_unrevealed_hash c level = *) (* let get_unrevealed_hash c level = *)
(* get_unrevealed c level >>=? fun (nonce_hash, _) -> *) (* get_unrevealed c level >>=? fun (nonce_hash, _) -> *)
(* return nonce_hash *) (* return nonce_hash *)
let record_hash c delegate_to_reward reward_amount nonce_hash = let record_hash c delegate_to_reward reward_amount nonce_hash =
let level = Level_storage.current c in let level = Level_storage.current c in

View File

@ -339,8 +339,8 @@ let encoding =
(merge_objs (merge_objs
(obj1 (req "hash" Operation_hash.encoding)) (obj1 (req "hash" Operation_hash.encoding))
(merge_objs (merge_objs
Operation.shell_header_encoding Operation.shell_header_encoding
Encoding.signed_proto_operation_encoding)) Encoding.signed_proto_operation_encoding))
let () = let () =
register_error_kind register_error_kind

View File

@ -152,13 +152,13 @@ module Make (T: QTY) : S = struct
let open Int64 in let open Int64 in
let rec step cur pow acc = let rec step cur pow acc =
if cur = 0L then if cur = 0L then
ok acc ok acc
else else
pow +? pow >>? fun npow -> pow +? pow >>? fun npow ->
if logand cur 1L = 1L then if logand cur 1L = 1L then
acc +? pow >>? fun nacc -> acc +? pow >>? fun nacc ->
step (shift_right_logical cur 1) npow nacc step (shift_right_logical cur 1) npow nacc
else else
step (shift_right_logical cur 1) npow acc in step (shift_right_logical cur 1) npow acc in
if m < 0L then if m < 0L then
error (Negative_multiplicator (t, m)) error (Negative_multiplicator (t, m))

View File

@ -57,7 +57,7 @@ let () =
(fun (contract, expr) -> (fun (contract, expr) ->
Runtime_contract_error (contract, expr)); Runtime_contract_error (contract, expr));
(* ---- interpreter ---------------------------------------------------------*) (* ---- interpreter ---------------------------------------------------------*)
type 'tys stack = type 'tys stack =
| Item : 'ty * 'rest stack -> ('ty * 'rest) stack | Item : 'ty * 'rest stack -> ('ty * 'rest) stack
@ -162,8 +162,8 @@ let rec interp
(init, qta, ctxt, origination) l >>=? fun (res, qta, ctxt, origination) -> (init, qta, ctxt, origination) l >>=? fun (res, qta, ctxt, origination) ->
logged_return ~origination (Item (res, rest), qta, ctxt) logged_return ~origination (Item (res, rest), qta, ctxt)
| List_size, Item (list, rest) -> | List_size, Item (list, rest) ->
let len = List.length list in let len = List.length list in
let len = Script_int.(abs (of_int len)) in let len = Script_int.(abs (of_int len)) in
logged_return (Item (len, rest), qta - 1, ctxt) logged_return (Item (len, rest), qta - 1, ctxt)
| List_iter body, Item (l, init_stack) -> | List_iter body, Item (l, init_stack) ->
fold_left_s fold_left_s

View File

@ -231,13 +231,13 @@ let compare_comparable
| Tez_key -> Tez.compare x y | Tez_key -> Tez.compare x y
| Key_hash_key -> Ed25519.Public_key_hash.compare x y | Key_hash_key -> Ed25519.Public_key_hash.compare x y
| Int_key -> | Int_key ->
let res = (Script_int.compare x y) in let res = (Script_int.compare x y) in
if Compare.Int.(res = 0) then 0 if Compare.Int.(res = 0) then 0
else if Compare.Int.(res > 0) then 1 else if Compare.Int.(res > 0) then 1
else -1 else -1
| Nat_key -> | Nat_key ->
let res = (Script_int.compare x y) in let res = (Script_int.compare x y) in
if Compare.Int.(res = 0) then 0 if Compare.Int.(res = 0) then 0
else if Compare.Int.(res > 0) then 1 else if Compare.Int.(res > 0) then 1
else -1 else -1
@ -968,14 +968,14 @@ let rec parse_data
(fun (last_value, set) v -> (fun (last_value, set) v ->
parse_comparable_data ?type_logger ctxt t v >>=? fun v -> parse_comparable_data ?type_logger ctxt t v >>=? fun v ->
begin match last_value with begin match last_value with
| Some value -> | Some value ->
if Compare.Int.(0 <= (compare_comparable t value v)) if Compare.Int.(0 <= (compare_comparable t value v))
then then
if Compare.Int.(0 = (compare_comparable t value v)) if Compare.Int.(0 = (compare_comparable t value v))
then fail (Duplicate_set_values (loc, strip_locations expr)) then fail (Duplicate_set_values (loc, strip_locations expr))
else fail (Unordered_set_values (loc, strip_locations expr)) else fail (Unordered_set_values (loc, strip_locations expr))
else return () else return ()
| None -> return () | None -> return ()
end >>=? fun () -> end >>=? fun () ->
return (Some v, set_update v true set)) return (Some v, set_update v true set))
(None, empty_set t) vs >>|? snd |> traced (None, empty_set t) vs >>|? snd |> traced
@ -984,28 +984,28 @@ let rec parse_data
(* Maps *) (* Maps *)
| Map_t (tk, tv), (Prim (loc, D_Map, vs, _) as expr) -> | Map_t (tk, tv), (Prim (loc, D_Map, vs, _) as expr) ->
(fold_left_s (fold_left_s
(fun (last_value, map) -> function (fun (last_value, map) -> function
| Prim (_, D_Item, [ k; v ], _) -> | Prim (_, D_Item, [ k; v ], _) ->
parse_comparable_data ?type_logger ctxt tk k >>=? fun k -> parse_comparable_data ?type_logger ctxt tk k >>=? fun k ->
parse_data ?type_logger ctxt tv v >>=? fun v -> parse_data ?type_logger ctxt tv v >>=? fun v ->
begin match last_value with begin match last_value with
| Some value -> | Some value ->
if Compare.Int.(0 <= (compare_comparable tk value k)) if Compare.Int.(0 <= (compare_comparable tk value k))
then then
if Compare.Int.(0 = (compare_comparable tk value k)) if Compare.Int.(0 = (compare_comparable tk value k))
then fail (Duplicate_map_keys (loc, strip_locations expr)) then fail (Duplicate_map_keys (loc, strip_locations expr))
else fail (Unordered_map_keys (loc, strip_locations expr)) else fail (Unordered_map_keys (loc, strip_locations expr))
else return () else return ()
| None -> return () | None -> return ()
end >>=? fun () -> end >>=? fun () ->
return (Some k, map_update k (Some v) map) return (Some k, map_update k (Some v) map)
| Prim (loc, D_Item, l, _) -> | Prim (loc, D_Item, l, _) ->
fail @@ Invalid_arity (loc, D_Item, 2, List.length l) fail @@ Invalid_arity (loc, D_Item, 2, List.length l)
| Prim (loc, name, _, _) -> | Prim (loc, name, _, _) ->
fail @@ Invalid_primitive (loc, [ D_Item ], name) fail @@ Invalid_primitive (loc, [ D_Item ], name)
| Int _ | String _ | Seq _ -> | Int _ | String _ | Seq _ ->
fail (error ())) fail (error ()))
(None, empty_map tk) vs) >>|? snd |> traced (None, empty_map tk) vs) >>|? snd |> traced
| Map_t _, expr -> | Map_t _, expr ->
traced (fail (unexpected expr [] Constant_namespace [ D_Map ])) traced (fail (unexpected expr [] Constant_namespace [ D_Map ]))
@ -1819,7 +1819,7 @@ type ex_script = Ex_script : ('a, 'b, 'c) script -> ex_script
let parse_script let parse_script
: ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Script.t -> ex_script tzresult Lwt.t context -> Script.t -> ex_script tzresult Lwt.t
= fun ?type_logger ctxt { code ; storage } -> = fun ?type_logger ctxt { code ; storage } ->
Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) -> Lwt.return (parse_toplevel code) >>=? fun (arg_type, ret_type, storage_type, code_field) ->
trace trace
@ -1885,7 +1885,7 @@ let typecheck_code
let typecheck_data let typecheck_data
: ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) -> : ?type_logger: (int -> Script.expr list -> Script.expr list -> unit) ->
context -> Script.expr * Script.expr -> unit tzresult Lwt.t context -> Script.expr * Script.expr -> unit tzresult Lwt.t
= fun ?type_logger ctxt (data, exp_ty) -> = fun ?type_logger ctxt (data, exp_ty) ->
trace trace
(Ill_formed_type (None, exp_ty, 0)) (Ill_formed_type (None, exp_ty, 0))
@ -1898,13 +1898,13 @@ let typecheck_data
(* ---- Error registration --------------------------------------------------*) (* ---- Error registration --------------------------------------------------*)
let ex_ty_enc = let ex_ty_enc =
Data_encoding.conv Data_encoding.conv
(fun (Ex_ty ty) -> strip_locations (unparse_ty None ty)) (fun (Ex_ty ty) -> strip_locations (unparse_ty None ty))
(fun expr -> (fun expr ->
match parse_ty (root expr) with match parse_ty (root expr) with
| Ok (Ex_ty ty, _) -> Ex_ty ty | Ok (Ex_ty ty, _) -> Ex_ty ty
| _ -> Ex_ty Unit_t (* FIXME: ? *)) | _ -> Ex_ty Unit_t (* FIXME: ? *))
Script.expr_encoding Script.expr_encoding
let () = let () =
let open Data_encoding in let open Data_encoding in
@ -2158,8 +2158,8 @@ let () =
~title:"Types contain inconsistent annotations" ~title:"Types contain inconsistent annotations"
~description:"The two types contain annotations that do not match" ~description:"The two types contain annotations that do not match"
(located (obj2 (located (obj2
(req "type1" ex_ty_enc) (req "type1" ex_ty_enc)
(req "type2" ex_ty_enc))) (req "type2" ex_ty_enc)))
(function (function
| Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (Ex_ty ty1, Ex_ty ty2)) | Inconsistent_type_annotations (loc, ty1, ty2) -> Some (loc, (Ex_ty ty1, Ex_ty ty2))
| _ -> None) | _ -> None)
@ -2295,8 +2295,8 @@ let () =
~description: ~description:
"The body of a map block did not match the expected type" "The body of a map block did not match the expected type"
(obj2 (obj2
(req "loc" Script.location_encoding) (req "loc" Script.location_encoding)
(req "bodyType" ex_stack_ty_enc)) (req "bodyType" ex_stack_ty_enc))
(function (function
| Invalid_map_body (loc, stack) -> | Invalid_map_body (loc, stack) ->
Some (loc, Ex_stack_ty stack) Some (loc, Ex_stack_ty stack)

View File

@ -303,7 +303,7 @@ and ('bef, 'aft) instr =
| Ge : | Ge :
(z num * 'rest, bool * 'rest) instr (z num * 'rest, bool * 'rest) instr
(* protocol *) (* protocol *)
| Manager : | Manager :
(('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr (('arg, 'ret) typed_contract * 'rest, public_key_hash * 'rest) instr
| Transfer_tokens : 'sto ty -> | Transfer_tokens : 'sto ty ->
@ -315,7 +315,7 @@ and ('bef, 'aft) instr =
(public_key_hash * 'rest, (unit, unit) typed_contract * 'rest) instr (public_key_hash * 'rest, (unit, unit) typed_contract * 'rest) instr
| Create_contract : 'g ty * 'p ty * 'r ty -> | Create_contract : 'g ty * 'p ty * 'r ty ->
(public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t * (public_key_hash * (public_key_hash option * (bool * (bool * (Tez.t *
(('p * 'g, 'r * 'g) lambda * ('g * 'rest)))))), (('p * 'g, 'r * 'g) lambda * ('g * 'rest)))))),
('p, 'r) typed_contract * 'rest) instr ('p, 'r) typed_contract * 'rest) instr
| Now : | Now :
('rest, Script_timestamp.t * 'rest) instr ('rest, Script_timestamp.t * 'rest) instr

View File

@ -167,7 +167,7 @@ module Context = struct
~input: empty ~input: empty
~output: ~output:
(wrap_tzerror @@ (wrap_tzerror @@
(obj1 (obj1
(req "voting_period_kind" Voting_period.kind_encoding))) (req "voting_period_kind" Voting_period.kind_encoding)))
RPC.Path.(custom_root / "context" / "voting_period_kind") RPC.Path.(custom_root / "context" / "voting_period_kind")
@ -195,20 +195,20 @@ module Context = struct
(fun () -> Forgotten) ; (fun () -> Forgotten) ;
] ]
let get custom_root = let get custom_root =
RPC.service RPC.service
~description: "Info about the nonce of a previous block." ~description: "Info about the nonce of a previous block."
~input: empty ~input: empty
~output: (wrap_tzerror nonce_encoding) ~output: (wrap_tzerror nonce_encoding)
RPC.Path.(custom_root / "context" / "nonce" /: Raw_level.arg) RPC.Path.(custom_root / "context" / "nonce" /: Raw_level.arg)
let hash custom_root = let hash custom_root =
RPC.service RPC.service
~description: "Hash of the current block's nonce." ~description: "Hash of the current block's nonce."
~input: empty ~input: empty
~output: (wrap_tzerror @@ ~output: (wrap_tzerror @@
describe ~title: "nonce hash" Nonce_hash.encoding) describe ~title: "nonce hash" Nonce_hash.encoding)
RPC.Path.(custom_root / "context" / "nonce") RPC.Path.(custom_root / "context" / "nonce")
end end

View File

@ -234,10 +234,10 @@ let minimal_timestamp ctxt prio =
Baking.minimal_time ctxt prio Baking.minimal_time ctxt prio
let () = register1 let () = register1
Services.Helpers.minimal_timestamp Services.Helpers.minimal_timestamp
(fun ctxt slot -> (fun ctxt slot ->
let timestamp = Tezos_context.Timestamp.current ctxt in let timestamp = Tezos_context.Timestamp.current ctxt in
minimal_timestamp ctxt slot timestamp) minimal_timestamp ctxt slot timestamp)
let () = let () =
(* ctxt accept_failing_script baker_contract pred_block block_prio operation *) (* ctxt accept_failing_script baker_contract pred_block block_prio operation *)
@ -355,7 +355,7 @@ let () =
Lwt_list.filter_map_p (fun x -> x) @@ Lwt_list.filter_map_p (fun x -> x) @@
List.mapi List.mapi
(fun prio c -> (fun prio c ->
let timestamp = Timestamp.current ctxt in let timestamp = Timestamp.current ctxt in
Baking.minimal_time ctxt prio timestamp >>= function Baking.minimal_time ctxt prio timestamp >>= function
| Error _ -> Lwt.return None | Error _ -> Lwt.return None
| Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp))) | Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp)))
@ -507,9 +507,9 @@ let check_signature ctxt signature shell contents =
Operation.check_signature source Operation.check_signature source
{ signature ; shell ; contents ; hash = dummy_hash } { signature ; shell ; contents ; hash = dummy_hash }
| Sourced_operations (Dictator_operation _) -> | Sourced_operations (Dictator_operation _) ->
let key = Constants.dictator_pubkey ctxt in let key = Constants.dictator_pubkey ctxt in
Operation.check_signature key Operation.check_signature key
{ signature ; shell ; contents ; hash = dummy_hash } { signature ; shell ; contents ; hash = dummy_hash }
let parse_operations ctxt (operations, check) = let parse_operations ctxt (operations, check) =
map_s begin fun raw -> map_s begin fun raw ->

View File

@ -88,15 +88,15 @@ let prepare ~level ~timestamp ~fitness ctxt =
may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) -> may_tag_first_block ctxt level >>=? fun (ctxt, first_block, first_level) ->
get_sandboxed ctxt >>=? fun sandbox -> get_sandboxed ctxt >>=? fun sandbox ->
Constants_repr.read sandbox >>=? function constants -> Constants_repr.read sandbox >>=? function constants ->
let level = let level =
Level_repr.from_raw Level_repr.from_raw
~first_level ~first_level
~cycle_length:constants.Constants_repr.cycle_length ~cycle_length:constants.Constants_repr.cycle_length
~voting_period_length:constants.Constants_repr.voting_period_length ~voting_period_length:constants.Constants_repr.voting_period_length
level in level in
return ({ context = ctxt ; constants ; level ; return ({ context = ctxt ; constants ; level ;
timestamp ; fitness ; first_level}, timestamp ; fitness ; first_level},
first_block) first_block)
let recover { context } : Context.t = context let recover { context } : Context.t = context
let first_level { first_level } = first_level let first_level { first_level } = first_level
@ -241,7 +241,7 @@ module Roll = struct
let encoding = Ed25519.Public_key_hash.encoding let encoding = Ed25519.Public_key_hash.encoding
end) end)
module Contract_roll_list = module Contract_roll_list =
Make_indexed_optional_data_storage(struct Make_indexed_optional_data_storage(struct
type key = Contract_repr.t type key = Contract_repr.t
type value = Roll_repr.t type value = Roll_repr.t
@ -438,7 +438,7 @@ module Vote = struct
let key = Key.Vote.ballots let key = Key.Vote.ballots
let name = "ballot" let name = "ballot"
let encoding = Vote_repr.ballot_encoding let encoding = Vote_repr.ballot_encoding
end) end)
end end

View File

@ -96,14 +96,14 @@ module Make_raw_data_storage (P : Raw_data_description) = struct
let init ({ context = c } as s) k v = let init ({ context = c } as s) k v =
let key = key k in let key = key k in
Context.get c key >>= Context.get c key >>=
function function
| Some _ -> | Some _ ->
let msg let msg
= "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in
fail (Storage_error msg) fail (Storage_error msg)
| None -> | None ->
Context.set c key (P.to_bytes v) >>= fun c -> Context.set c key (P.to_bytes v) >>= fun c ->
return { s with context = c } return { s with context = c }
(* Does not verify that the key is present or not *) (* Does not verify that the key is present or not *)
let init_set ({ context = c } as s) k v = let init_set ({ context = c } as s) k v =
@ -292,10 +292,10 @@ module Raw_make_iterable_data_storage
module HashTbl = module HashTbl =
Persist.MakePersistentMap(Context)(K)(struct Persist.MakePersistentMap(Context)(K)(struct
type t = P.value type t = P.value
let of_bytes b = Data_encoding.Binary.of_bytes P.encoding b let of_bytes b = Data_encoding.Binary.of_bytes P.encoding b
let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v let to_bytes v = Data_encoding.Binary.to_bytes P.encoding v
end) end)
let key_to_string k = String.concat "/" (K.to_path k) let key_to_string k = String.concat "/" (K.to_path k)
@ -329,14 +329,14 @@ module Raw_make_iterable_data_storage
(* Verify that the key is not present before inserting *) (* Verify that the key is not present before inserting *)
let init ({ context = c } as s) k v = let init ({ context = c } as s) k v =
HashTbl.get c k >>= HashTbl.get c k >>=
function function
| Some _ -> | Some _ ->
let msg let msg
= "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in = "cannot init existing " ^ P.name ^ " key " ^ key_to_string k in
fail (Storage_error msg) fail (Storage_error msg)
| None -> | None ->
HashTbl.set c k v >>= fun c -> HashTbl.set c k v >>= fun c ->
return { s with context = c } return { s with context = c }
(* Does not verify that the key is present or not *) (* Does not verify that the key is present or not *)
let init_set ({ context = c } as s) k v = let init_set ({ context = c } as s) k v =

View File

@ -669,10 +669,10 @@ module Block_header : sig
val forge_unsigned: val forge_unsigned:
Block_header.shell_header -> proto_header -> MBytes.t Block_header.shell_header -> proto_header -> MBytes.t
(** [forge_header shell_hdr proto_hdr] is the binary serialization (** [forge_header shell_hdr proto_hdr] is the binary serialization
(using [unsigned_header_encoding]) of a block header, (using [unsigned_header_encoding]) of a block header,
comprising both the shell and the protocol part of the header, comprising both the shell and the protocol part of the header,
without the signature. *) without the signature. *)
end end

View File

@ -11,7 +11,7 @@
type proposal = Protocol_hash.t type proposal = Protocol_hash.t
(* votes can be for, against or neutral. (* votes can be for, against or neutral.
Neutral serves to count towards a quorum *) Neutral serves to count towards a quorum *)
type ballot = Yay | Nay | Pass type ballot = Yay | Nay | Pass
let ballot_encoding = let ballot_encoding =

View File

@ -33,7 +33,7 @@ let get_ballots ctxt =
Storage.Vote.Ballots.fold ctxt Storage.Vote.Ballots.fold ctxt
~f:(fun delegate ballot (ballots: ballots tzresult) -> ~f:(fun delegate ballot (ballots: ballots tzresult) ->
Storage.Vote.Listings.get ctxt delegate >>=? fun weight -> Storage.Vote.Listings.get ctxt delegate >>=? fun weight ->
let count = Int32.add weight in let count = Int32.add weight in
Lwt.return begin Lwt.return begin
ballots >>? fun ballots -> ballots >>? fun ballots ->
match ballot with match ballot with

View File

@ -76,7 +76,7 @@ let begin_construction
~predecessor:_ ~predecessor:_
~timestamp:_ ~timestamp:_
?proto_header:_ () = ?proto_header:_ () =
Fitness.to_int64 pred_fitness >>=? function pred_fitness -> Fitness.to_int64 pred_fitness >>=? fun pred_fitness ->
let fitness = Int64.succ pred_fitness in let fitness = Int64.succ pred_fitness in
return { context ; fitness } return { context ; fitness }

View File

@ -66,8 +66,8 @@ let rpc_services : Updater.rpc_context RPC.directory =
(Forge.block RPC.Path.root) (Forge.block RPC.Path.root)
(fun _ctxt ((net_id, level, proto_level, predecessor, (fun _ctxt ((net_id, level, proto_level, predecessor,
timestamp, fitness), command) -> timestamp, fitness), command) ->
let shell = { Block_header.net_id ; level ; proto_level ; predecessor ; let shell = { Block_header.net_id ; level ; proto_level ; predecessor ;
timestamp ; fitness ; validation_passes = 1 ; operations_hash } in timestamp ; fitness ; validation_passes = 1 ; operations_hash } in
let bytes = Data.Command.forge shell command in let bytes = Data.Command.forge shell command in
RPC.Answer.return bytes) in RPC.Answer.return bytes) in
dir dir

View File

@ -13,7 +13,7 @@
* WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
* ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
* OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*) *)
open Error_monad open Error_monad

View File

@ -30,7 +30,7 @@ module Alphabet = struct
if Bytes.get str char <> '\255' then if Bytes.get str char <> '\255' then
Format.kasprintf invalid_arg Format.kasprintf invalid_arg
"Base58: invalid alphabet (dup '%c' %d %d)" "Base58: invalid alphabet (dup '%c' %d %d)"
(char_of_int char) (int_of_char @@ Bytes.get str char) i ; (char_of_int char) (int_of_char @@ Bytes.get str char) i ;
Bytes.set str char (char_of_int i) ; Bytes.set str char (char_of_int i) ;
done ; done ;
{ encode = alphabet ; decode = Bytes.to_string str } { encode = alphabet ; decode = Bytes.to_string str }
@ -91,10 +91,10 @@ let raw_encode ?(alphabet=Alphabet.default) s =
let s = Z.of_bits s in let s = Z.of_bits s in
let rec loop s = let rec loop s =
if s = Z.zero then 0 else if s = Z.zero then 0 else
let s, r = Z.div_rem s zbase in let s, r = Z.div_rem s zbase in
let i = loop s in let i = loop s in
Bytes.set res i (to_char ~alphabet (Z.to_int r)) ; Bytes.set res i (to_char ~alphabet (Z.to_int r)) ;
i + 1 in i + 1 in
let i = loop s in let i = loop s in
let res = Bytes.sub_string res 0 i in let res = Bytes.sub_string res 0 i in
String.make zeros zero ^ res String.make zeros zero ^ res
@ -105,9 +105,9 @@ let raw_decode ?(alphabet=Alphabet.default) s =
let len = String.length s in let len = String.length s in
let rec loop res i = let rec loop res i =
if i = len then res else if i = len then res else
let x = Z.of_int (of_char ~alphabet (String.get s i)) in let x = Z.of_int (of_char ~alphabet (String.get s i)) in
let res = Z.(add x (mul res zbase)) in let res = Z.(add x (mul res zbase)) in
loop res (i+1) loop res (i+1)
in in
let res = Z.to_bits @@ loop Z.zero zeros in let res = Z.to_bits @@ loop Z.zero zeros in
let res_tzeros = count_trailing_char res '\000' in let res_tzeros = count_trailing_char res '\000' in

View File

@ -36,13 +36,13 @@ let increment_nonce = Sodium.Box.increment_nonce
let box = Sodium.Box.Bigbytes.box let box = Sodium.Box.Bigbytes.box
let box_open sk pk msg nonce = let box_open sk pk msg nonce =
try Some (Sodium.Box.Bigbytes.box_open sk pk msg nonce) with try Some (Sodium.Box.Bigbytes.box_open sk pk msg nonce) with
| Sodium.Verification_failure -> None | Sodium.Verification_failure -> None
let precompute = Sodium.Box.precompute let precompute = Sodium.Box.precompute
let fast_box = Sodium.Box.Bigbytes.fast_box let fast_box = Sodium.Box.Bigbytes.fast_box
let fast_box_open ck msg nonce = let fast_box_open ck msg nonce =
try Some (Sodium.Box.Bigbytes.fast_box_open ck msg nonce) with try Some (Sodium.Box.Bigbytes.fast_box_open ck msg nonce) with
| Sodium.Verification_failure -> None | Sodium.Verification_failure -> None
let compare_target hash target = let compare_target hash target =
let hash = Z.of_bits (Hash.Generic_hash.to_string hash) in let hash = Z.of_bits (Hash.Generic_hash.to_string hash) in
@ -91,21 +91,21 @@ let generate_proof_of_work ?max pk target =
let public_key_encoding = let public_key_encoding =
let open Data_encoding in let open Data_encoding in
conv conv
Sodium.Box.Bigbytes.of_public_key Sodium.Box.Bigbytes.of_public_key
Sodium.Box.Bigbytes.to_public_key Sodium.Box.Bigbytes.to_public_key
(Fixed.bytes Sodium.Box.public_key_size) (Fixed.bytes Sodium.Box.public_key_size)
let secret_key_encoding = let secret_key_encoding =
let open Data_encoding in let open Data_encoding in
conv conv
Sodium.Box.Bigbytes.of_secret_key Sodium.Box.Bigbytes.of_secret_key
Sodium.Box.Bigbytes.to_secret_key Sodium.Box.Bigbytes.to_secret_key
(Fixed.bytes Sodium.Box.secret_key_size) (Fixed.bytes Sodium.Box.secret_key_size)
let nonce_encoding = let nonce_encoding =
let open Data_encoding in let open Data_encoding in
conv conv
Sodium.Box.Bigbytes.of_nonce Sodium.Box.Bigbytes.of_nonce
Sodium.Box.Bigbytes.to_nonce Sodium.Box.Bigbytes.to_nonce
(Fixed.bytes Sodium.Box.nonce_size) (Fixed.bytes Sodium.Box.nonce_size)

View File

@ -125,7 +125,7 @@ module Make() = struct
let classify_error error = let classify_error error =
let rec find e = function let rec find e = function
| [] -> `Temporary | [] -> `Temporary
(* assert false (\* See "Generic error" *\) *) (* assert false (\* See "Generic error" *\) *)
| Error_kind { from_error ; category } :: rest -> | Error_kind { from_error ; category } :: rest ->
match from_error e with match from_error e with
| Some x -> begin | Some x -> begin
@ -368,72 +368,72 @@ module Make() = struct
(Format.pp_print_list pp) (Format.pp_print_list pp)
(List.rev errors) (List.rev errors)
type error += Unclassified of string type error += Unclassified of string
let () = let () =
let id = "" in let id = "" in
let category = `Temporary in let category = `Temporary in
let to_error msg = Unclassified msg in let to_error msg = Unclassified msg in
let from_error = function let from_error = function
| Unclassified msg -> Some msg | Unclassified msg -> Some msg
| error -> | error ->
let msg = Obj.(extension_name @@ extension_constructor error) in let msg = Obj.(extension_name @@ extension_constructor error) in
Some ("Unclassified error: " ^ msg ^ ". Was the error registered?") in Some ("Unclassified error: " ^ msg ^ ". Was the error registered?") in
let title = "Generic error" in let title = "Generic error" in
let description = "An unclassified error" in let description = "An unclassified error" in
let encoding_case = let encoding_case =
let open Data_encoding in let open Data_encoding in
case case
(describe ~title ~description @@ (describe ~title ~description @@
conv (fun x -> ((), x)) (fun ((), x) -> x) @@ conv (fun x -> ((), x)) (fun ((), x) -> x) @@
(obj2 (obj2
(req "kind" (constant "generic")) (req "kind" (constant "generic"))
(req "error" string))) (req "error" string)))
from_error to_error in from_error to_error in
let pp = Format.pp_print_string in let pp = Format.pp_print_string in
error_kinds := error_kinds :=
Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds
type error += Assert_error of string * string type error += Assert_error of string * string
let () = let () =
let id = "" in let id = "" in
let category = `Permanent in let category = `Permanent in
let to_error (loc, msg) = Assert_error (loc, msg) in let to_error (loc, msg) = Assert_error (loc, msg) in
let from_error = function let from_error = function
| Assert_error (loc, msg) -> Some (loc, msg) | Assert_error (loc, msg) -> Some (loc, msg)
| _ -> None in | _ -> None in
let title = "Assertion error" in let title = "Assertion error" in
let description = "An fatal assertion" in let description = "An fatal assertion" in
let encoding_case = let encoding_case =
let open Data_encoding in let open Data_encoding in
case case
(describe ~title ~description @@ (describe ~title ~description @@
conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y)) @@ conv (fun (x, y) -> ((), x, y)) (fun ((), x, y) -> (x, y)) @@
(obj3 (obj3
(req "kind" (constant "assertion")) (req "kind" (constant "assertion"))
(req "location" string) (req "location" string)
(req "error" string))) (req "error" string)))
from_error to_error in from_error to_error in
let pp ppf (loc, msg) = let pp ppf (loc, msg) =
Format.fprintf ppf Format.fprintf ppf
"Assert failure (%s)%s" "Assert failure (%s)%s"
loc loc
(if msg = "" then "." else ": " ^ msg) in (if msg = "" then "." else ": " ^ msg) in
error_kinds := error_kinds :=
Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds Error_kind { id; from_error ; category; encoding_case ; pp } :: !error_kinds
let _assert b loc fmt = let _assert b loc fmt =
if b then if b then
Format.ikfprintf (fun _ -> return ()) Format.str_formatter fmt Format.ikfprintf (fun _ -> return ()) Format.str_formatter fmt
else else
Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt Format.kasprintf (fun msg -> fail (Assert_error (loc, msg))) fmt
let protect ~on_error t = let protect ~on_error t =
t >>= function t >>= function
| Ok res -> return res | Ok res -> return res
| Error err -> on_error err | Error err -> on_error err
end end

View File

@ -251,14 +251,14 @@ module Make_minimal_Blake2B (K : Name) = struct
module Table = struct module Table = struct
include Hashtbl.Make(struct include Hashtbl.Make(struct
type nonrec t = t type nonrec t = t
let hash s = let hash s =
Int64.to_int Int64.to_int
(EndianString.BigEndian.get_int64 (EndianString.BigEndian.get_int64
(Bytes.unsafe_to_string (Sodium.Generichash.Bytes.of_hash s)) (Bytes.unsafe_to_string (Sodium.Generichash.Bytes.of_hash s))
0) 0)
let equal = equal let equal = equal
end) end)
end end
end end
@ -691,10 +691,10 @@ module Net_id = struct
module Table = struct module Table = struct
include Hashtbl.Make(struct include Hashtbl.Make(struct
type nonrec t = t type nonrec t = t
let hash = Hashtbl.hash let hash = Hashtbl.hash
let equal = equal let equal = equal
end) end)
end end
end end

Some files were not shown because too many files have changed in this diff Show More