unikernel/duniverse/lwt-dllist/.gitignore

@@ -0,0 +1,4 @@
+_build
+.merlin
+*.install
+.*.swp

unikernel/duniverse/lwt-dllist/CHANGES.md

@@ -0,0 +1,14 @@
+## v1.1.0 (2025-04-28)
+
+- Add missing primitive `clear` (@raphael-proust, #7)
+- Fix documentation typo (@raphael-proust, #7)
+
+## v1.0.1 (2021-05-21)
+
+- Remove `lwt` dependency; it's only really needed for the tests (@aantron #1).
+- Fix deprecation warnings with OCaml 4.08 (@aantron #1).
+- Add support for OCaml 4.02 (@aantron #1).
+
+## v1.0.0 (2019-01-14)
+
+Initial release, based on Lwt 4.1.0's source code.

unikernel/duniverse/lwt-dllist/LICENSE.md

@@ -0,0 +1,17 @@
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

unikernel/duniverse/lwt-dllist/Makefile

@@ -0,0 +1,13 @@
+.PHONY: clean doc all test
+
+all:
+	dune build
+
+doc:
+	dune build @doc
+
+clean:
+	dune clean
+
+test:
+	dune runtest

unikernel/duniverse/lwt-dllist/README.md

@@ -0,0 +1,25 @@
+# lwt-dllist - Mutable doubly-linked list
+
+An `Lwt_dllist` is an object holding a list of elements which support
+the following operations:
+
+- adding an element to the left or the right in time and space O(1)
+- taking an element from the left or the right in time and space O(1)
+- removing a previously added element from a sequence in time and space O(1)
+- removing an element while the sequence is being traversed.
+
+## History
+
+This module was formerly part of the Lwt core distribution as the
+`Lwt_sequence` module, but has been pulled out into a separate library since it
+is really just an implementation detail of Lwt.
+
+You can migrate existing uses of `Lwt_sequence` into `Lwt_dllist` by simply
+renaming the module.  The implementation of the module remains unchanged, but
+the name reflects the fact that the implementation is a doubly-linked list.
+
+## Further Reading
+
+- Docs: <https://mirage.github.io/lwt-dllist>
+- Issues: <https://github.com/mirage/lwt-dllist/issues>
+- Discussion: <https://discuss.ocaml.org> with the MirageOS tag.

unikernel/duniverse/lwt-dllist/dune-project

@@ -0,0 +1,3 @@
+(lang dune 1.0)
+(name lwt-dllist)
+(version v1.1.0)

unikernel/duniverse/lwt-dllist/lwt-dllist.opam

@@ -0,0 +1,29 @@
+version: "1.1.0"
+opam-version: "2.0"
+maintainer: [ "Anil Madhavapeddy <anil@recoil.org>" ]
+authors: ["Jérôme Vouillon" "Jérémie Dimino"]
+license: "MIT"
+homepage: "https://github.com/mirage/lwt-dllist"
+doc: "https://mirage.github.io/lwt-dllist/"
+bug-reports: "https://github.com/mirage/lwt-dllist/issues"
+depends: [
+  "ocaml" {>= "4.02.0"}
+  "lwt" {with-test}
+  "dune"
+]
+build: [
+ ["dune" "subst" ] {pinned}
+ ["dune" "build" "-p" name "-j" jobs]
+ ["dune" "runtest" "-p" name "-j" jobs] {with-test}
+]
+dev-repo: "git+https://github.com/mirage/lwt-dllist.git"
+synopsis: "Mutable doubly-linked list with Lwt iterators"
+description: """
+A sequence is an object holding a list of elements which support
+the following operations:
+
+- adding an element to the left or the right in time and space O(1)
+- taking an element from the left or the right in time and space O(1)
+- removing a previously added element from a sequence in time and space O(1)
+- removing an element while the sequence is being transversed.
+"""

unikernel/duniverse/lwt-dllist/src/dune

@@ -0,0 +1,4 @@
+(library
+ (name lwt_dllist)
+ (synopsis "Mutable doubly-linked list")
+ (public_name lwt-dllist))

unikernel/duniverse/lwt-dllist/src/lwt_dllist.ml

@@ -0,0 +1,230 @@
+(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
+   details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+
+
+exception Empty
+
+type 'a t = {
+  mutable prev : 'a t;
+  mutable next : 'a t;
+}
+
+type 'a node = {
+  node_prev : 'a t;
+  node_next : 'a t;
+  mutable node_data : 'a;
+  mutable node_active : bool;
+}
+
+external seq_of_node : 'a node -> 'a t = "%identity"
+external node_of_seq : 'a t -> 'a node = "%identity"
+
+(* +-----------------------------------------------------------------+
+   | Operations on nodes                                             |
+   +-----------------------------------------------------------------+ *)
+
+let get node =
+  node.node_data
+
+let set node data =
+  node.node_data <- data
+
+let remove node =
+  if node.node_active then begin
+    node.node_active <- false;
+    let seq = seq_of_node node in
+    seq.prev.next <- seq.next;
+    seq.next.prev <- seq.prev
+  end
+
+(* +-----------------------------------------------------------------+
+   | Operations on sequences                                         |
+   +-----------------------------------------------------------------+ *)
+
+let create () =
+  let rec seq = { prev = seq; next = seq } in
+  seq
+
+let clear seq =
+  seq.prev <- seq;
+  seq.next <- seq
+
+let is_empty seq = seq.next == seq
+
+let length seq =
+  let rec loop curr len =
+    if curr == seq then
+      len
+    else
+      let node = node_of_seq curr in loop node.node_next (len + 1)
+  in
+  loop seq.next 0
+
+let add_l data seq =
+  let node = { node_prev = seq; node_next = seq.next; node_data = data; node_active = true } in
+  seq.next.prev <- seq_of_node node;
+  seq.next <- seq_of_node node;
+  node
+
+let add_r data seq =
+  let node = { node_prev = seq.prev; node_next = seq; node_data = data; node_active = true } in
+  seq.prev.next <- seq_of_node node;
+  seq.prev <- seq_of_node node;
+  node
+
+let take_l seq =
+  if is_empty seq then
+    raise Empty
+  else begin
+    let node = node_of_seq seq.next in
+    remove node;
+    node.node_data
+  end
+
+let take_r seq =
+  if is_empty seq then
+    raise Empty
+  else begin
+    let node = node_of_seq seq.prev in
+    remove node;
+    node.node_data
+  end
+
+let take_opt_l seq =
+  if is_empty seq then
+    None
+  else begin
+    let node = node_of_seq seq.next in
+    remove node;
+    Some node.node_data
+  end
+
+let take_opt_r seq =
+  if is_empty seq then
+    None
+  else begin
+    let node = node_of_seq seq.prev in
+    remove node;
+    Some node.node_data
+  end
+
+let transfer_l s1 s2 =
+  s2.next.prev <- s1.prev;
+  s1.prev.next <- s2.next;
+  s2.next <- s1.next;
+  s1.next.prev <- s2;
+  s1.prev <- s1;
+  s1.next <- s1
+
+let transfer_r s1 s2 =
+  s2.prev.next <- s1.next;
+  s1.next.prev <- s2.prev;
+  s2.prev <- s1.prev;
+  s1.prev.next <- s2;
+  s1.prev <- s1;
+  s1.next <- s1
+
+let iter_l f seq =
+  let rec loop curr =
+    if curr != seq then begin
+      let node = node_of_seq curr in
+      if node.node_active then f node.node_data;
+      loop node.node_next
+    end
+  in
+  loop seq.next
+
+let iter_r f seq =
+  let rec loop curr =
+    if curr != seq then begin
+      let node = node_of_seq curr in
+      if node.node_active then f node.node_data;
+      loop node.node_prev
+    end
+  in
+  loop seq.prev
+
+let iter_node_l f seq =
+  let rec loop curr =
+    if curr != seq then begin
+      let node = node_of_seq curr in
+      if node.node_active then f node;
+      loop node.node_next
+    end
+  in
+  loop seq.next
+
+let iter_node_r f seq =
+  let rec loop curr =
+    if curr != seq then begin
+      let node = node_of_seq curr in
+      if node.node_active then f node;
+      loop node.node_prev
+    end
+  in
+  loop seq.prev
+
+let fold_l f seq acc =
+  let rec loop curr acc =
+    if curr == seq then
+      acc
+    else
+      let node = node_of_seq curr in
+      if node.node_active then
+        loop node.node_next (f node.node_data acc)
+      else
+        loop node.node_next acc
+  in
+  loop seq.next acc
+
+let fold_r f seq acc =
+  let rec loop curr acc =
+    if curr == seq then
+      acc
+    else
+      let node = node_of_seq curr in
+      if node.node_active then
+        loop node.node_prev (f node.node_data acc)
+      else
+        loop node.node_prev acc
+  in
+  loop seq.prev acc
+
+let find_node_l f seq =
+  let rec loop curr =
+    if curr != seq then
+      let node = node_of_seq curr in
+      if node.node_active then
+        if f node.node_data then
+          node
+        else
+          loop node.node_next
+      else
+        loop node.node_next
+    else
+      raise Not_found
+  in
+  loop seq.next
+
+let find_node_r f seq =
+  let rec loop curr =
+    if curr != seq then
+      let node = node_of_seq curr in
+      if node.node_active then
+        if f node.node_data then
+          node
+        else
+          loop node.node_prev
+      else
+        loop node.node_prev
+    else
+      raise Not_found
+  in
+  loop seq.prev
+
+let find_node_opt_l f seq =
+  try Some (find_node_l f seq) with Not_found -> None
+
+let find_node_opt_r f seq =
+  try Some (find_node_r f seq) with Not_found -> None

unikernel/duniverse/lwt-dllist/src/lwt_dllist.mli

@@ -0,0 +1,141 @@
+(* This file is formerly part of Lwt, released under the MIT license.
+ * See LICENSE.md for details, or visit
+ * https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+(** Mutable double-linked list of elements *)
+
+(** A sequence is an object holding a list of elements which support
+    the following operations:
+
+    - adding an element to the left or the right in time and space O(1)
+    - taking an element from the left or the right in time and space O(1)
+    - removing a previously added element from a sequence in time and space O(1)
+    - removing an element while the sequence is being transversed.
+*)
+
+type 'a t
+  (** Type of a sequence holding values of type ['a] *)
+
+type 'a node
+  (** Type of a node holding one value of type ['a] in a sequence *)
+
+(** {2 Operation on nodes} *)
+
+val get : 'a node -> 'a
+  (** Returns the contents of a node *)
+
+val set : 'a node -> 'a -> unit
+  (** Changes the contents of a node *)
+
+val remove : 'a node -> unit
+  (** Removes a node from the sequence it is part of. It does nothing
+      if the node has already been removed. *)
+
+(** {2 Operations on sequence} *)
+
+val create : unit -> 'a t
+  (** [create ()] creates a new empty sequence *)
+
+val clear : 'a t -> unit
+(** Removes all nodes from the given sequence. The nodes are not actually
+    mutated to note their removal. Only the sequence's pointers are updated. *)
+
+val is_empty : 'a t -> bool
+  (** Returns [true] iff the given sequence is empty *)
+
+val length : 'a t -> int
+  (** Returns the number of elements in the given sequence. This is a
+      O(n) operation where [n] is the number of elements in the
+      sequence. *)
+
+val add_l : 'a -> 'a t -> 'a node
+  (** [add_l x s] adds [x] to the left of the sequence [s] *)
+
+val add_r : 'a -> 'a t -> 'a node
+  (** [add_r x s] adds [x] to the right of the sequence [s] *)
+
+exception Empty
+  (** Exception raised by [take_l] and [take_r] and when the sequence
+      is empty *)
+
+val take_l : 'a t -> 'a
+  (** [take_l x s] removes and returns the leftmost element of [s]
+
+      @raise Empty if the sequence is empty *)
+
+val take_r : 'a t -> 'a
+  (** [take_r x s] removes and returns the rightmost element of [s]
+
+      @raise Empty if the sequence is empty *)
+
+val take_opt_l : 'a t -> 'a option
+  (** [take_opt_l x s] removes and returns [Some x] where [x] is the
+      leftmost element of [s] or [None] if [s] is empty *)
+
+val take_opt_r : 'a t -> 'a option
+  (** [take_opt_r x s] removes and returns [Some x] where [x] is the
+      rightmost element of [s] or [None] if [s] is empty *)
+
+val transfer_l : 'a t -> 'a t -> unit
+  (** [transfer_l s1 s2] removes all elements of [s1] and add them at
+      the left of [s2]. This operation runs in constant time and
+      space. *)
+
+val transfer_r : 'a t -> 'a t -> unit
+  (** [transfer_r s1 s2] removes all elements of [s1] and add them at
+      the right of [s2]. This operation runs in constant time and
+      space. *)
+
+(** {2 Sequence iterators} *)
+
+(** Note: it is OK to remove a node while traversing a sequence *)
+
+val iter_l : ('a -> unit) -> 'a t -> unit
+  (** [iter_l f s] applies [f] on all elements of [s] starting from
+      the left *)
+
+val iter_r : ('a -> unit) -> 'a t -> unit
+  (** [iter_r f s] applies [f] on all elements of [s] starting from
+      the right *)
+
+val iter_node_l : ('a node -> unit) -> 'a t -> unit
+  (** [iter_node_l f s] applies [f] on all nodes of [s] starting from
+      the left *)
+
+val iter_node_r : ('a node -> unit) -> 'a t -> unit
+  (** [iter_node_r f s] applies [f] on all nodes of [s] starting from
+      the right *)
+
+val fold_l : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  (** [fold_l f s] is:
+      {[
+        fold_l f s x = f en (... (f e2 (f e1 x)))
+      ]}
+      where [e1], [e2], ..., [en] are the elements of [s]
+  *)
+
+val fold_r : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+  (** [fold_r f s] is:
+      {[
+        fold_r f s x = f e1 (f e2 (... (f en x)))
+      ]}
+      where [e1], [e2], ..., [en] are the elements of [s]
+  *)
+
+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
+      [s] starting from the left that satisfies [f] or [None] if none
+      exists. *)
+
+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
+      [s] starting from the right that satisfies [f] or [None] if none
+      exists. *)
+
+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
+      that satisfies [f] or raises [Not_found] if none exists. *)
+
+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
+      that satisfies [f] or raises [Not_found] if none exists. *)

unikernel/duniverse/lwt-dllist/test/dune

@@ -0,0 +1,8 @@
+(executable
+ (name main)
+ (libraries lwt lwt.unix lwt-dllist)
+ (flags (:standard -w +A-40-42)))
+
+(alias
+ (name runtest)
+ (action (run %{exe:main.exe})))

unikernel/duniverse/lwt-dllist/test/main.ml

@@ -0,0 +1 @@
+Test.run "dllist" [ Test_lwt_dllist.suite ]

unikernel/duniverse/lwt-dllist/test/test.ml

@@ -0,0 +1,211 @@
+(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
+   details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+[@@@warning "-4"]
+
+type test = {
+  test_name : string;
+  skip_if_this_is_false : unit -> bool;
+  run : unit -> bool Lwt.t;
+}
+
+type outcome =
+  | Passed
+  | Failed
+  | Exception of exn
+  | Skipped
+
+exception Skip
+
+let test_direct test_name ?(only_if = fun () -> true) run =
+  let run =
+    fun () ->
+      Lwt.return (run ())
+  in
+  {test_name; skip_if_this_is_false = only_if; run}
+
+let test test_name ?(only_if = fun () -> true) run =
+  {test_name; skip_if_this_is_false = only_if; run}
+
+let run_test : test -> outcome Lwt.t = fun test ->
+  if test.skip_if_this_is_false () = false then
+    Lwt.return Skipped
+
+  else begin
+    (* Lwt.async_exception_hook handling inspired by
+         https://github.com/mirage/alcotest/issues/45 *)
+    let async_exception_promise, async_exception_occurred = Lwt.task () in
+    let old_async_exception_hook = !Lwt.async_exception_hook in
+    Lwt.async_exception_hook := (fun exn ->
+      Lwt.wakeup_later async_exception_occurred (Exception exn));
+
+    Lwt.finalize
+      (fun () ->
+
+        let test_completion_promise =
+          Lwt.try_bind
+            (fun () ->
+              test.run ())
+
+            (fun test_did_pass ->
+              if test_did_pass then
+                Lwt.return Passed
+              else
+                Lwt.return Failed)
+
+            (function
+            | Skip ->
+              Lwt.return Skipped
+
+            | exn_raised_by_test ->
+              Lwt.return (Exception exn_raised_by_test))
+        in
+
+        Lwt.pick [test_completion_promise; async_exception_promise])
+
+      (fun () ->
+        Lwt.async_exception_hook := old_async_exception_hook;
+        Lwt.return_unit)
+  end
+
+let outcome_to_character : outcome -> string = function
+  | Passed -> "."
+  | Failed -> "F"
+  | Exception _ -> "E"
+  | Skipped -> "S"
+
+
+
+type suite = {
+  suite_name : string;
+  suite_tests : test list;
+  skip_suite_if_this_is_false : unit -> bool;
+}
+
+let suite name ?(only_if = fun () -> true) tests =
+  {suite_name = name;
+   suite_tests = tests;
+   skip_suite_if_this_is_false = only_if}
+
+let run_test_suite : suite -> ((string * outcome) list) Lwt.t = fun suite ->
+  if suite.skip_suite_if_this_is_false () = false then
+    let outcomes =
+      suite.suite_tests
+      |> List.map (fun {test_name; _} -> (test_name, Skipped))
+    in
+    (outcome_to_character Skipped).[0]
+    |> String.make (List.length outcomes)
+    |> print_string;
+    flush stdout;
+
+    Lwt.return outcomes
+
+  else
+    suite.suite_tests |> Lwt_list.map_s begin fun test ->
+      Lwt.bind (run_test test) (fun outcome ->
+      outcome |> outcome_to_character |> print_string;
+      flush stdout;
+      Lwt.return (test.test_name, outcome))
+    end
+
+let outcomes_all_ok : (string * outcome) list -> bool =
+  List.for_all (fun (_test_name, outcome) ->
+    match outcome with
+    | Passed | Skipped -> true
+    | Failed | Exception _ -> false)
+
+let show_failures : (string * outcome) list -> unit =
+  List.iter (fun (test_name, outcome) ->
+    match outcome with
+    | Passed
+    | Skipped ->
+      ()
+
+    | Failed ->
+      Printf.eprintf
+        "Test '%s' produced 'false'\n" test_name
+
+    | Exception exn ->
+      Printf.eprintf
+        "Test '%s' raised '%s'\n" test_name (Printexc.to_string exn))
+
+
+
+type aggregated_outcomes = (string * ((string * outcome) list)) list
+
+let fold_over_outcomes :
+    ('a -> suite_name:string -> test_name:string -> outcome -> 'a) ->
+    'a ->
+    aggregated_outcomes ->
+      'a =
+
+    fun f init outcomes ->
+
+  List.fold_left (fun accumulator (suite_name, test_outcomes) ->
+    List.fold_left (fun accumulator (test_name, test_outcome) ->
+      f accumulator ~suite_name ~test_name test_outcome)
+      accumulator
+      test_outcomes)
+    init
+    outcomes
+
+let count_ran : aggregated_outcomes -> int =
+  fold_over_outcomes
+    (fun count ~suite_name:_ ~test_name:_ -> function
+      | Skipped ->
+        count
+      | _ ->
+        count + 1)
+    0
+
+let count_skipped : aggregated_outcomes -> int =
+  fold_over_outcomes
+    (fun count ~suite_name:_ ~test_name:_ -> function
+      | Skipped ->
+        count + 1
+      | _ ->
+        count)
+    0
+
+(* Runs a series of test suites. If one of the test suites fails, does not run
+   subsequent suites. *)
+let run library_name suites =
+  Printexc.register_printer (function
+    | Failure message -> Some (Printf.sprintf "Failure(%S)" message)
+    | _ -> None);
+
+  Printf.printf "Testing library '%s'...\n" library_name;
+
+  let rec loop_over_suites aggregated_outcomes suites =
+    match suites with
+    | [] ->
+      Printf.printf
+        "\nOk. %i tests ran, %i tests skipped\n"
+        (count_ran aggregated_outcomes)
+        (count_skipped aggregated_outcomes);
+      Lwt.return_unit
+
+    | suite::rest ->
+      Lwt.bind (run_test_suite suite) begin fun outcomes ->
+        if not (outcomes_all_ok outcomes) then begin
+          print_newline ();
+          flush stdout;
+          Printf.eprintf "Failures in test suite '%s':\n" suite.suite_name;
+          show_failures outcomes;
+          exit 1
+        end
+        else
+          loop_over_suites
+            ((suite.suite_name, outcomes)::aggregated_outcomes) rest
+      end
+  in
+
+  loop_over_suites [] suites
+  |> Lwt_main.run
+
+let with_async_exception_hook hook f =
+  let old_hook = !Lwt.async_exception_hook in
+  Lwt.async_exception_hook := hook;
+  Lwt.finalize f (fun () ->
+    Lwt.async_exception_hook := old_hook;
+    Lwt.return ())

unikernel/duniverse/lwt-dllist/test/test.mli

@@ -0,0 +1,40 @@
+(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
+   details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+
+
+(** Helpers for tests. *)
+
+type test
+(** Type of a test *)
+
+type suite
+(** Type of a suite of tests *)
+
+exception Skip
+(** In some tests, it is only clear that the test should be skipped after it has
+    started running (for example, after an attempted system call raises a
+    certain exception, indicating it is not supported).
+
+    Such tests should raise [Test.Skip], or reject their final promise with
+    [Test.Skip]. *)
+
+val test_direct : string -> ?only_if:(unit -> bool) -> (unit -> bool) -> test
+(** Defines a test. [run] must returns [true] if the test succeeded
+    and [false] otherwise. [only_if] is used to conditionally skip the
+    test. *)
+
+val test : string -> ?only_if:(unit -> bool) -> (unit -> bool Lwt.t) -> test
+(** Like [test_direct], but defines a test which runs a thread. *)
+
+val suite : string -> ?only_if:(unit -> bool) -> test list -> suite
+(** Defines a suite of tests *)
+
+val run : string -> suite list -> unit
+(** Run all the given tests and exit the program with an exit code
+    of [0] if all tests succeeded and with [1] otherwise. *)
+
+val with_async_exception_hook : (exn -> unit) -> (unit -> 'a Lwt.t) -> 'a Lwt.t
+(** [Test.with_async_exception_hook hook f] sets [!Lwt.async_exception_hook] to
+    [hook], runs [f ()], and then restores [!Lwt.async_exception_hook] to its
+    former value. *)

unikernel/duniverse/lwt-dllist/test/test_lwt_dllist.ml

@@ -0,0 +1,417 @@
+(* This file is part of Lwt, released under the MIT license. See LICENSE.md for
+   details, or visit https://github.com/ocsigen/lwt/blob/master/LICENSE.md. *)
+
+open Test
+
+let filled_sequence () =
+  let s = Lwt_dllist.create () in
+  let _ = Lwt_dllist.add_r 1 s in
+  let _ = Lwt_dllist.add_r 2 s in
+  let _ = Lwt_dllist.add_r 3 s in
+  let _ = Lwt_dllist.add_r 4 s in
+  let _ = Lwt_dllist.add_r 5 s in
+  let _ = Lwt_dllist.add_r 6 s in
+  s
+
+let filled_length = 6
+
+let leftmost_value = 1
+
+let rightmost_value = 6
+
+let transfer_sequence () =
+  let s = Lwt_dllist.create () in
+  let _ = Lwt_dllist.add_r 7 s in
+  let _ = Lwt_dllist.add_r 8 s in
+  s
+
+let transfer_length = 2
+
+let empty_array = [||]
+
+let l_filled_array = [|1; 2; 3; 4; 5; 6|]
+
+let r_filled_array = [|6; 5; 4; 3; 2; 1|]
+
+let factorial_sequence = 720
+
+let test_iter iter_f array_values seq =
+  let index = ref 0 in
+  Lwt.catch
+   (fun () ->
+    iter_f (fun v ->
+              assert (v = array_values.(!index));
+              index := (!index + 1)) seq;
+    Lwt.return_true)
+   (function _ -> Lwt.return_false)
+
+let test_iter_node iter_f array_values seq =
+  let index = ref 0 in
+  Lwt.catch
+   (fun () ->
+    iter_f (fun n ->
+              assert ((Lwt_dllist.get n) = array_values.(!index));
+              index := (!index + 1)) seq;
+    Lwt.return_true)
+   (function _ -> Lwt.return_false)
+
+let test_iter_rem iter_f array_values seq =
+  let index = ref 0 in
+  Lwt.catch
+   (fun () ->
+    iter_f (fun n ->
+              assert ((Lwt_dllist.get n) = array_values.(!index));
+              Lwt_dllist.remove n;
+              index := (!index + 1)) seq;
+    Lwt.return_true)
+   (function _ -> Lwt.return_false)
+
+let suite = suite "lwt_sequence" [
+
+  test "create" begin fun () ->
+    let s = Lwt_dllist.create () in
+    let _ = assert (Lwt_dllist.is_empty s) in
+    let len = Lwt_dllist.length s in
+    Lwt.return (len = 0)
+  end;
+
+  test "add_l" begin fun () ->
+    let s = Lwt_dllist.create () in
+    let n = Lwt_dllist.add_l 1 s in
+    let _ = assert ((Lwt_dllist.get n) = 1) in
+    let len = Lwt_dllist.length s in
+    Lwt.return (len = 1)
+  end;
+
+  test "add_r" begin fun () ->
+    let s = Lwt_dllist.create () in
+    let n = Lwt_dllist.add_r 1 s in
+    let _ = assert ((Lwt_dllist.get n) = 1) in
+    let len = Lwt_dllist.length s in
+    Lwt.return (len = 1)
+  end;
+
+  test "take_l Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    Lwt.catch
+      (fun () ->
+        let _ = Lwt_dllist.take_l s in
+        Lwt.return_false)
+      (function
+        | Lwt_dllist.Empty -> Lwt.return_true
+        | _ -> Lwt.return_false)
+  end;
+
+  test "take_l" begin fun () ->
+    let s = filled_sequence () in
+    Lwt.catch
+      (fun () ->
+        let v = Lwt_dllist.take_l s in
+        Lwt.return (leftmost_value = v))
+      (function _ -> Lwt.return_false)
+  end;
+
+  test "take_r Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    Lwt.catch
+      (fun () ->
+        let _ = Lwt_dllist.take_r s in Lwt.return_false)
+      (function
+        | Lwt_dllist.Empty -> Lwt.return_true
+        | _ -> Lwt.return_false)
+  end;
+
+  test "take_r" begin fun () ->
+    let s = filled_sequence () in
+    Lwt.catch
+      (fun () ->
+        let v = Lwt_dllist.take_r s in Lwt.return (rightmost_value = v))
+      (function _ -> Lwt.return_false)
+  end;
+
+  test "take_opt_l Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    match Lwt_dllist.take_opt_l s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "take_opt_l" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.take_opt_l s with
+    | None -> Lwt.return_false
+    | Some v -> Lwt.return (leftmost_value = v)
+  end;
+
+  test "take_opt_r Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    match Lwt_dllist.take_opt_r s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "take_opt_r" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.take_opt_r s with
+    | None -> Lwt.return_false
+    | Some v -> Lwt.return (rightmost_value = v)
+  end;
+
+  test "transfer_l Empty" begin fun () ->
+    let s = filled_sequence () in
+    let ts = Lwt_dllist.create () in
+    let _ = Lwt_dllist.transfer_l ts s in
+    let len = Lwt_dllist.length s in
+    Lwt.return (filled_length = len)
+  end;
+
+  test "transfer_l " begin fun () ->
+    let s = filled_sequence () in
+    let ts = transfer_sequence () in
+    let _ = Lwt_dllist.transfer_l ts s in
+    let len = Lwt_dllist.length s in
+    let _ = assert ((filled_length + transfer_length) = len) in
+    match Lwt_dllist.take_opt_l s with
+    | None -> Lwt.return_false
+    | Some v -> Lwt.return (7 = v)
+  end;
+
+  test "transfer_r Empty" begin fun () ->
+    let s = filled_sequence () in
+    let ts = Lwt_dllist.create () in
+    let _ = Lwt_dllist.transfer_r ts s in
+    let len = Lwt_dllist.length s in
+    Lwt.return (filled_length = len)
+  end;
+
+  test "transfer_r " begin fun () ->
+    let s = filled_sequence () in
+    let ts = transfer_sequence () in
+    let _ = Lwt_dllist.transfer_r ts s in
+    let len = Lwt_dllist.length s in
+    let _ = assert ((filled_length + transfer_length) = len) in
+    match Lwt_dllist.take_opt_r s with
+    | None -> Lwt.return_false
+    | Some v -> Lwt.return (8 = v)
+  end;
+
+  test "iter_l Empty" begin fun () ->
+    test_iter Lwt_dllist.iter_l empty_array (Lwt_dllist.create ())
+  end;
+
+  test "iter_l" begin fun () ->
+    test_iter Lwt_dllist.iter_l l_filled_array (filled_sequence ())
+  end;
+
+  test "iter_r Empty" begin fun () ->
+    test_iter Lwt_dllist.iter_r empty_array (Lwt_dllist.create ())
+  end;
+
+  test "iter_r" begin fun () ->
+    test_iter Lwt_dllist.iter_r r_filled_array (filled_sequence ())
+  end;
+
+  test "iter_node_l Empty" begin fun () ->
+    test_iter_node Lwt_dllist.iter_node_l empty_array (Lwt_dllist.create ())
+  end;
+
+  test "iter_node_l" begin fun () ->
+    test_iter_node Lwt_dllist.iter_node_l l_filled_array (filled_sequence ())
+  end;
+
+  test "iter_node_r Empty" begin fun () ->
+    test_iter_node Lwt_dllist.iter_node_r empty_array (Lwt_dllist.create ())
+  end;
+
+  test "iter_node_r" begin fun () ->
+    test_iter_node Lwt_dllist.iter_node_r r_filled_array (filled_sequence ())
+  end;
+
+  test "iter_node_l with removal" begin fun () ->
+    test_iter_rem Lwt_dllist.iter_node_l l_filled_array (filled_sequence ())
+  end;
+
+  test "iter_node_r with removal" begin fun () ->
+    test_iter_rem Lwt_dllist.iter_node_r r_filled_array (filled_sequence ())
+  end;
+
+  test "fold_l" begin fun () ->
+    let acc = Lwt_dllist.fold_l (fun v e -> v * e) (filled_sequence ()) 1 in
+    Lwt.return (factorial_sequence = acc)
+  end;
+
+  test "fold_l Empty" begin fun () ->
+    let acc = Lwt_dllist.fold_l (fun v e -> v * e) (Lwt_dllist.create ()) 1 in
+    Lwt.return (acc = 1)
+  end;
+
+  test "fold_r" begin fun () ->
+    let acc = Lwt_dllist.fold_r (fun v e -> v * e) (filled_sequence ()) 1 in
+    Lwt.return (factorial_sequence = acc)
+  end;
+
+  test "fold_r Empty" begin fun () ->
+    let acc = Lwt_dllist.fold_r (fun v e -> v * e) (Lwt_dllist.create ()) 1 in
+    Lwt.return (acc = 1)
+  end;
+
+  test "find_node_opt_l Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "find_node_opt_l not found " begin fun () ->
+    let s = transfer_sequence () in
+    match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "find_node_opt_l" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.find_node_opt_l (fun v -> v = 1) s with
+    | None -> Lwt.return_false
+    | Some n -> if ((Lwt_dllist.get n) = 1) then Lwt.return_true
+      else Lwt.return_false
+  end;
+
+  test "find_node_opt_r Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "find_node_opt_r not found " begin fun () ->
+    let s = transfer_sequence () in
+    match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
+    | None -> Lwt.return_true
+    | _ -> Lwt.return_false
+  end;
+
+  test "find_node_opt_r" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.find_node_opt_r (fun v -> v = 1) s with
+    | None -> Lwt.return_false
+    | Some n -> if ((Lwt_dllist.get n) = 1) then Lwt.return_true
+      else Lwt.return_false
+  end;
+
+  test "find_node_l Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    Lwt.catch
+    (fun () -> let n = Lwt_dllist.find_node_l (fun v -> v = 1) s in
+       if ((Lwt_dllist.get n) = 1) then Lwt.return_false
+       else Lwt.return_false)
+    (function
+      | Not_found -> Lwt.return_true
+      | _ -> Lwt.return_false)
+  end;
+
+  test "find_node_l" begin fun () ->
+    let s = filled_sequence () in
+    Lwt.catch
+    (fun () -> let n = Lwt_dllist.find_node_l (fun v -> v = 1) s in
+       if ((Lwt_dllist.get n) = 1) then Lwt.return_true
+       else Lwt.return_false)
+    (function _ -> Lwt.return_false)
+  end;
+
+  test "find_node_r Empty" begin fun () ->
+    let s = Lwt_dllist.create () in
+    Lwt.catch
+    (fun () -> let n = Lwt_dllist.find_node_r (fun v -> v = 1) s in
+       if ((Lwt_dllist.get n) = 1) then Lwt.return_false
+       else Lwt.return_false)
+    (function
+      | Not_found -> Lwt.return_true
+      | _ -> Lwt.return_false)
+  end;
+
+  test "find_node_r" begin fun () ->
+    let s = filled_sequence () in
+    Lwt.catch
+    (fun () -> let n = Lwt_dllist.find_node_r (fun v -> v = 1) s in
+       if ((Lwt_dllist.get n) = 1) then Lwt.return_true
+       else Lwt.return_false)
+    (function _ -> Lwt.return_false)
+  end;
+
+  test "set" begin fun () ->
+    let s = filled_sequence () in
+    match Lwt_dllist.find_node_opt_l (fun v -> v = 4) s with
+    | None -> Lwt.return_false
+    | Some n -> let _ = Lwt_dllist.set n 10 in
+      let data = [|1; 2; 3; 10; 5; 6|] in
+      test_iter Lwt_dllist.iter_l data s
+  end;
+
+  test "fold_r with multiple removal" begin fun () ->
+    let s = filled_sequence () in
+    let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
+    let n_two = Lwt_dllist.find_node_r (fun v' -> v' = 2) s in
+    let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
+    let acc = Lwt_dllist.fold_r begin fun v e ->
+      if v = 3 then begin
+         let _ = Lwt_dllist.remove n_three in
+         let _ = Lwt_dllist.remove n_two in
+         ignore(Lwt_dllist.remove n_four)
+      end;
+      v * e
+    end s 1 in
+    Lwt.return (acc = (factorial_sequence / 2))
+  end;
+
+  test "fold_l multiple removal" begin fun () ->
+   let s = filled_sequence () in
+   let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
+   let n_five = Lwt_dllist.find_node_r (fun v' -> v' = 5) s in
+   let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
+   let acc = Lwt_dllist.fold_l begin fun v e ->
+      if v = 4 then begin
+         let _ = Lwt_dllist.remove n_four in
+         let _ = Lwt_dllist.remove n_five in
+         ignore(Lwt_dllist.remove n_three)
+      end;
+      v * e
+   end s 1 in
+    Lwt.return (acc = (factorial_sequence / 5))
+  end;
+
+  test "find_node_r with multiple removal" begin fun () ->
+    let s = filled_sequence () in
+    let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
+    let n_two = Lwt_dllist.find_node_r (fun v' -> v' = 2) s in
+    Lwt.catch
+    begin fun () ->
+      let n = Lwt_dllist.find_node_r begin fun v ->
+        if v = 3 then (
+          let _ = Lwt_dllist.remove n_three in
+          ignore(Lwt_dllist.remove n_two));
+        v = 1
+       end s in
+      let v = Lwt_dllist.get n in
+      Lwt.return (v = 1)
+    end
+    (function _ -> Lwt.return_false)
+  end;
+
+  test "find_node_l with multiple removal" begin fun () ->
+    let s = filled_sequence () in
+    let n_three = Lwt_dllist.find_node_r (fun v' -> v' = 3) s in
+    let n_four = Lwt_dllist.find_node_r (fun v' -> v' = 4) s in
+    Lwt.catch
+    begin fun () ->
+      let n = Lwt_dllist.find_node_l begin fun v ->
+        if v = 3 then (
+          let _ = Lwt_dllist.remove n_three in
+          ignore(Lwt_dllist.remove n_four));
+        v = 6 end s in
+      let v = Lwt_dllist.get n in
+      Lwt.return (v = 6)
+    end
+    (function _ -> Lwt.return_false)
+  end;
+]