(*
Author : AlexLusitania
Version : 1.0
Date : 08/01/2014
Description : The sequence of triangle numbers is generated by adding the natural numbers. So the 7th triangle number would be 1+2+3+4+5+6+7 = 28. The first ten terms would be : 1,3,6,10,15,21,28,36,45,55,... Let us list the factors of the first seven triangle numbers : 1:1; 3:1,3; 6:1,2,3,6; 10:1,2,5,10; 15:1,3,5,15; 21:1,3,7,21; 28:1,2,4,7,14,28; We can see that 28 is the first triangle number to have over five divisors. What is the value of the first triangle number to have over five hundred divisors ?
*)

Add naive version to count the triangle numbers divisors

(*
Author : AlexLusitania
Version : 1.0
Date : 08/01/2014
Description : The sequence of triangle numbers is generated by adding the natural numbers. So the 7th triangle number would be 1+2+3+4+5+6+7 = 28. The first ten terms would be : 1,3,6,10,15,21,28,36,45,55,... Let us list the factors of the first seven triangle numbers : 1:1; 3:1,3; 6:1,2,3,6; 10:1,2,5,10; 15:1,3,5,15; 21:1,3,7,21; 28:1,2,4,7,14,28; We can see that 28 is the first triangle number to have over five divisors. What is the value of the first triangle number to have over five hundred divisors ?
*)

(* Naive version *)
let count_divisors x =
	let rec local acc i = match i with
	| 0 -> acc
	| 1 -> (acc+1)
	| _ -> if (x mod i = 0) then local (acc+1) (i-(i/2)) else local acc (i-1)
	in local 1 (x/2);;

(* Find naively the first triangle over x divisors *)
let f x =
	let rec local num i = match num,i with
	| num,i when (count_divisors num > x) -> num
	| _ -> local (num+i) (i+1)
	in local 1 2;;


open Webtest

let test_assert_true_ok () =
  assert_true "should pass" true

let test_assert_true_fail () =
  try
    assert_true "test_bool" false;
    failwith "assert_true should have failed"
  with TestFailure "test value was false: test_bool" -> ()

let test_assert_equal_ok () =
  assert_equal 5 5

let test_assert_equal_fail () =
  try
    assert_equal 5 6;
    failwith "assert_equal should have failed"
  with TestFailure "not equal" -> ()

let suite =
  "base_suite" >::: [
    "test_assert_true_ok" >:: test_assert_true_ok;
    "test_assert_true_fail" >:: test_assert_true_fail;
    "test_assert_equal_ok" >:: test_assert_equal_ok;
    "test_assert_equal_fail" >:: test_assert_equal_fail;
  ]

Add a test of the assert_equal printer

open Webtest

let test_assert_true_ok () =
  assert_true "should pass" true

let test_assert_true_fail () =
  try
    assert_true "test_bool" false;
    failwith "assert_true should have failed"
  with TestFailure "test value was false: test_bool" -> ()

let test_assert_equal_ok () =
  assert_equal 5 5

let test_assert_equal_fail () =
  try
    assert_equal 5 6;
    failwith "assert_equal should have failed"
  with TestFailure "not equal" -> ()

let test_assert_equal_printer () =
  try
    assert_equal ~printer:string_of_int 5 6;
    failwith "assert_equal should have failed"
  with TestFailure "not equal: 5 6" -> ()

let suite =
  "base_suite" >::: [
    "test_assert_true_ok" >:: test_assert_true_ok;
    "test_assert_true_fail" >:: test_assert_true_fail;
    "test_assert_equal_ok" >:: test_assert_equal_ok;
    "test_assert_equal_fail" >:: test_assert_equal_fail;
    "test_assert_equal_printer" >:: test_assert_equal_printer;
  ]


open Lwt
open Irmin_unix

let () =
  try match Sys.getenv "DEBUG" with
    | "" -> ()
    | _  ->
      Log.color_on ();
      Log.set_log_level Log.DEBUG
  with Not_found -> ()

let path =
  if Array.length Sys.argv = 2 then
    Sys.argv.(1)
  else
    "git://github.com/mirage/ocaml-git.git"

let store = Irmin.basic (module Irmin_git.FS) (module Irmin.Contents.String)

let upstream =
  (* Note: https:// and http:// are not yet supported *)
  Irmin.remote_uri path

let test () =
  let config = Irmin_git.config ~root:"/tmp/test" () in
  Irmin.create store config task >>= fun t ->
  Irmin.pull_exn (t "Syncing with upstream store") upstream `Update >>= fun () ->
  Irmin.read_exn (t "get the README") ["README.md"]>>= fun readme ->
  Printf.printf "%s\n%!" readme;
  return_unit

let () =
  Lwt_main.run (test ())

Add an example of using the new view API

open Lwt
open Irmin_unix

let () =
  try match Sys.getenv "DEBUG" with
    | "" -> ()
    | _  ->
      Log.color_on ();
      Log.set_log_level Log.DEBUG
  with Not_found -> ()

let path =
  if Array.length Sys.argv = 2 then
    Sys.argv.(1)
  else
    "git://github.com/mirage/ocaml-git.git"

let store = Irmin.basic (module Irmin_git.FS) (module Irmin.Contents.String)

let upstream =
  (* Note: https:// and http:// are not yet supported *)
  Irmin.remote_uri path

let test () =
  let config = Irmin_git.config ~root:"/tmp/test" () in
  Irmin.create store config task >>= fun t ->
  Irmin.pull_exn (t "Syncing with upstream store") upstream `Update >>= fun () ->
  Irmin.read_exn (t "get the README") ["README.md"]>>= fun readme ->
  Irmin.with_hrw_view (t "Updating BAR and FOO") `Merge (fun view ->
      Irmin.update view ["BAR.md"] "Hoho!" >>= fun () ->
      Irmin.update view ["FOO.md"] "Hihi!" >>= fun () ->
      Lwt.return_unit
    ) >>= Irmin.Merge.exn >>= fun () ->
  Printf.printf "%s\n%!" readme;
  return_unit

let () =
  Lwt_main.run (test ())


open Lwt.Infix
let target_ip = Ipaddr.V4.of_string_exn "10.0.0.1"

module Main (S: V1_LWT.STACKV4) = struct
  let buffer = Io_page.get 1 |> Io_page.to_cstruct

  let start s =
    let t = S.tcpv4 s in

    S.TCPV4.create_connection t (target_ip, 7001) >>= function
    | `Error _err -> failwith "Connection to port 7001 failed"
    | `Ok flow ->

    let payload = Cstruct.sub buffer 0 1 in
    Cstruct.set_char payload 0 '!';

    S.TCPV4.write flow payload >>= function
    | `Error _ | `Eof -> assert false
    | `Ok () ->

    S.TCPV4.close flow
end

Add a link to the wiki.

(* This unikernel is based on tracing documentation:
   https://mirage.io/wiki/profiling
*)

open Lwt.Infix
let target_ip = Ipaddr.V4.of_string_exn "10.0.0.1"

module Main (S: V1_LWT.STACKV4) = struct
  let buffer = Io_page.get 1 |> Io_page.to_cstruct

  let start s =
    let t = S.tcpv4 s in

    S.TCPV4.create_connection t (target_ip, 7001) >>= function
    | `Error _err -> failwith "Connection to port 7001 failed"
    | `Ok flow ->

    let payload = Cstruct.sub buffer 0 1 in
    Cstruct.set_char payload 0 '!';

    S.TCPV4.write flow payload >>= function
    | `Error _ | `Eof -> assert false
    | `Ok () ->

    S.TCPV4.close flow
end


open OUnit

let base_suite =
	"base_suite" >:::
		[
			Test_config.test;
		]

let _ = run_test_tt_main base_suite

Make sure tests don't exit 0 even when they fail

open OUnit

let base_suite =
	"base_suite" >:::
		[
			Test_config.test;
		]

let () =
	OUnit2.run_test_tt_main (OUnit.ounit2_of_ounit1 base_suite)


open Sexplib.Std

type address = {
	domain: int;
	bus: int;
	dev: int;
	fn: int;
}
[@@deriving sexp, rpc, rpcty]

let address_of_string str =
	Scanf.sscanf str "%04x:%02x:%02x.%02x"
		(fun domain bus dev fn -> {domain; bus; dev; fn})

let string_of_address address =
	Printf.sprintf "%04x:%02x:%02x.%01x"
		address.domain address.bus address.dev address.fn

Fix PCI function address formatting .%02x -> .%x

open Sexplib.Std

type address = {
	domain: int;
	bus: int;
	dev: int;
	fn: int;
}
[@@deriving sexp, rpc, rpcty]

let address_of_string str =
	Scanf.sscanf str "%04x:%02x:%02x.%x"
		(fun domain bus dev fn -> {domain; bus; dev; fn})

let string_of_address address =
	Printf.sprintf "%04x:%02x:%02x.%x"
		address.domain address.bus address.dev address.fn


(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)
open! IStd
module F = Format

type t = OperationCost | AllocationCost | AutoreleasepoolSize [@@deriving compare]

let to_issue_string = function
  | OperationCost ->
      "EXECUTION_TIME"
  | AllocationCost ->
      "ALLOCATION"
  | AutoreleasepoolSize ->
      "AUTORELEASEPOOL_SIZE"

let to_complexity_string = function
  | AllocationCost ->
      "Allocation complexity"
  | AutoreleasepoolSize ->
      "Autoreleasepool size"
  | OperationCost ->
      "Time complexity"

let pp f k =
  let k_str =
    match k with
    | OperationCost ->
        "Execution Cost"
    | AllocationCost ->
        "Allocation Cost"
    | AutoreleasepoolSize ->
        "Autoreleasepool Size"
  in
  F.pp_print_string f k_str

let to_json_cost_info c = function
  | OperationCost ->
      c.Jsonbug_t.exec_cost
  | AllocationCost ->
      assert false
  | AutoreleasepoolSize ->
      c.Jsonbug_t.autoreleasepool_size

type kind_spec = {kind: t; (* for non-diff analysis *) top_and_unreachable: bool}

let enabled_cost_kinds =
  [ {kind= OperationCost; top_and_unreachable= true}
  ; {kind= AutoreleasepoolSize; top_and_unreachable= false} ]

Enable top_and_unreachable issues of autoreleasepool size

(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)
open! IStd
module F = Format

type t = OperationCost | AllocationCost | AutoreleasepoolSize [@@deriving compare]

let to_issue_string = function
  | OperationCost ->
      "EXECUTION_TIME"
  | AllocationCost ->
      "ALLOCATION"
  | AutoreleasepoolSize ->
      "AUTORELEASEPOOL_SIZE"

let to_complexity_string = function
  | AllocationCost ->
      "Allocation complexity"
  | AutoreleasepoolSize ->
      "Autoreleasepool size"
  | OperationCost ->
      "Time complexity"

let pp f k =
  let k_str =
    match k with
    | OperationCost ->
        "Execution Cost"
    | AllocationCost ->
        "Allocation Cost"
    | AutoreleasepoolSize ->
        "Autoreleasepool Size"
  in
  F.pp_print_string f k_str

let to_json_cost_info c = function
  | OperationCost ->
      c.Jsonbug_t.exec_cost
  | AllocationCost ->
      assert false
  | AutoreleasepoolSize ->
      c.Jsonbug_t.autoreleasepool_size

type kind_spec = {kind: t; (* for non-diff analysis *) top_and_unreachable: bool}

let enabled_cost_kinds =
  [ {kind= OperationCost; top_and_unreachable= true}
  ; {kind= AutoreleasepoolSize; top_and_unreachable= true} ]


let () =
  let (//) = Filename.concat in
  let path_to_ppx =
    Path.build_dir //
    Path.to_root //
    "../.." //
    "_build/install/default/lib/bisect_ppx/ppx.exe"
  in
  let arguments =
    match Array.to_list Sys.argv with
    | program::arguments ->
      Array.of_list (program::
        "--as-ppx"::"--no-comment-parsing"::"--conditional"::arguments)
    | _ ->
      Sys.argv
  in
  Unix.execv path_to_ppx arguments

Fix path to ppx.exe on Mac

let () =
  let rec find_node_modules path =
    match path with
    | "" -> None
    | _ when path = Filename.current_dir_name -> None
    | _ when path = Filename.dir_sep -> None
    | _ ->
      if Filename.basename path = "node_modules" then
        Some path
      else
        find_node_modules (Filename.dirname path)
  in

  let (//) = Filename.concat in
  let ppx_exe = "_build/install/default/lib/bisect_ppx/ppx.exe" in

  let path_to_ppx =
    match find_node_modules (Sys.argv.(0)) with
    | Some node_modules ->
      node_modules // "@aantron/bisect_ppx" // ppx_exe
    | None ->
      Path.build_dir // Path.to_root // "../.." // ppx_exe
  in

  let arguments =
    match Array.to_list Sys.argv with
    | program::arguments ->
      Array.of_list (program::
        "--as-ppx"::"--no-comment-parsing"::"--conditional"::arguments)
    | _ ->
      Sys.argv
  in
  Unix.execv path_to_ppx arguments


(* Create an IPv4 header.
 * $Id: make_ipv4_header.ml,v 1.2 2008-04-01 17:31:12 rjones Exp $
 *)

open Printf

let version = 4
let hdrlen = 5				(* no options *)
let tos = 16
let length = 64				(* total packet length *)
let identification = 0
let flags = 0
let fragoffset = 0
let ttl = 255
let protocol = 17			(* UDP *)
let checksum = 0
let source = 0xc0a80202			(* 192.168.2.2 *)
let dest = 0xc0a80201			(* 192.168.2.1 *)
let options = Bitmatch.empty_bitstring
let payload_length = (length - hdrlen*4) * 8
let payload = Bitmatch.create_bitstring payload_length

let header =
  BITSTRING {
    version : 4; hdrlen : 4; tos : 8; length : 16;
    identification : 16; flags : 3; fragoffset : 13;
    ttl : 8; protocol : 8; checksum : 16;
    source : 32;
    dest : 32;
    options : -1, bitstring;
    payload : payload_length, bitstring
  }

let () = Bitmatch.file_of_bitstring header "ipv4_header_out.dat"

Fix this example so it now works.

(* Create an IPv4 header.
 * $Id: make_ipv4_header.ml,v 1.2 2008-04-01 17:31:12 rjones Exp $
 *)

open Printf

let version = 4
let hdrlen = 5				(* no options *)
let tos = 16
let length = 64				(* total packet length *)
let identification = 0
let flags = 0
let fragoffset = 0
let ttl = 255
let protocol = 17			(* UDP *)
let checksum = 0
let source = 0xc0a80202_l		(* 192.168.2.2 *)
let dest = 0xc0a80201_l			(* 192.168.2.1 *)
let options = Bitmatch.empty_bitstring
let payload_length = (length - hdrlen*4) * 8
let payload = Bitmatch.create_bitstring payload_length

let header =
  BITSTRING {
    version : 4; hdrlen : 4; tos : 8; length : 16;
    identification : 16; flags : 3; fragoffset : 13;
    ttl : 8; protocol : 8; checksum : 16;
    source : 32;
    dest : 32
(*
  Not implemented at the moment XXX
    options : -1 : bitstring;
    payload : payload_length : bitstring
*)
  }

let () = Bitmatch.bitstring_to_file header "ipv4_header_out.dat"


open Common

type t = { name  : string
         ; synopsis : string
         ; help  : string
         ; usage : string
         ; specs : (Arg.key * Arg.spec * Arg.doc) list
         ; anon  : string -> unit
         ; main  : unit -> unit
         }

module StringMap = Map.Make(String)

let all = ref StringMap.empty

let make ~name ~synopsis ?(help="") ?(usage="") main =
  { name; synopsis; help; usage
  ; specs = []
  ; anon = (Log.error "Don't know what to do with %S")
  ; main
  }

and register ({ name; _ } as t) =
  all := StringMap.add name t !all

and find name =
  try
    StringMap.find name !all
  with Not_found ->
    failwithf "Subcommand %S doesn't exist" name

and fold ~f ~init =
  StringMap.fold f !all init

Use 'failwithf' instead of 'Log.error' in 'SubCommand'

open Common

type t = { name  : string
         ; synopsis : string
         ; help  : string
         ; usage : string
         ; specs : (Arg.key * Arg.spec * Arg.doc) list
         ; anon  : string -> unit
         ; main  : unit -> unit
         }

module StringMap = Map.Make(String)

let all = ref StringMap.empty

let make ~name ~synopsis ?(help="") ?(usage="") main =
  { name; synopsis; help; usage
  ; specs = []
  ; anon = (failwithf "Don't know what to do with %S")
  ; main
  }

and register ({ name; _ } as t) =
  all := StringMap.add name t !all

and find name =
  try
    StringMap.find name !all
  with Not_found ->
    failwithf "Subcommand %S doesn't exist" name

and fold ~f ~init =
  StringMap.fold f !all init


open OUnit

let rec foldi n f acc =
	if n = 0 then acc else foldi (pred n) f (f acc)

let test_db =
	let open Filename in
	String.concat dir_sep
		[ (foldi 4 dirname Sys.executable_name); "lib_test"; "mock-pci.ids" ]

let with_test_db (f: Pci_db.t -> unit) =
	let pci_db = Pci_db.of_file test_db in
	f pci_db

let test_of_file _ =
	with_test_db (fun _ -> ())

let _ =
	let suite = "pci_db" >:::
		[
			"test_of_file" >:: test_of_file;
		]
	in
	run_test_tt ~verbose:true suite

Add unit test for print function

open OUnit

let skip_test_print = true

let rec foldi n f acc =
	if n = 0 then acc else foldi (pred n) f (f acc)

let test_db =
	let open Filename in
	String.concat dir_sep
		[ (foldi 4 dirname Sys.executable_name); "lib_test"; "mock-pci.ids" ]

let with_test_db (f: Pci_db.t -> unit) =
	let pci_db = Pci_db.of_file test_db in
	f pci_db

let test_of_file _ =
	with_test_db (fun _ -> ())

let test_print _ =
	skip_if skip_test_print "test_print";
	with_test_db (fun db ->
		Pci_db.print db
	)

let _ =
	let suite = "pci_db" >:::
		[
			"test_of_file" >:: test_of_file;
			"test_print" >:: test_print;
		]
	in
	run_test_tt ~verbose:true suite


open Prelude.Ana
open GobConfig
module Q = Queries

let is_global (a: Q.ask) (v: varinfo): bool =
  v.vglob || ThreadEscape.has_escaped a v

let is_static (v:varinfo): bool = v.vstorage = Static

let is_always_unknown variable = variable.vstorage = Extern || Ciltools.is_volatile_tp variable.vtype

let exclude_from_earlyglobs = ref []
let exclude_from_invalidation = ref []

let is_excluded_from_earlyglobs v = List.mem v.vname !exclude_from_earlyglobs
let is_excluded_from_invalidation v =  List.mem v.vname !exclude_from_invalidation

let after_config () =
  exclude_from_earlyglobs := get_string_list "exp.exclude_from_earlyglobs";
  exclude_from_invalidation := get_string_list "exp.exclude_from_invalidation"

let _ =
  AfterConfig.register after_config

Remove extra level of caching

open Prelude.Ana
open GobConfig
module Q = Queries

let is_global (a: Q.ask) (v: varinfo): bool =
  v.vglob || ThreadEscape.has_escaped a v

let is_static (v:varinfo): bool = v.vstorage = Static

let is_always_unknown variable = variable.vstorage = Extern || Ciltools.is_volatile_tp variable.vtype

let is_excluded_from_earlyglobs v = List.mem v.vname (get_string_list "exp.exclude_from_earlyglobs")
let is_excluded_from_invalidation v =  List.mem v.vname (get_string_list "exp.exclude_from_invalidation")


(* RUN: %ocamlc llvm.cma llvm_analysis.cma %s -o %t
 * RUN: ./%t %t.bc
 *)

open Llvm
open Llvm_analysis

(* Note that this takes a moment to link, so it's best to keep the number of
   individual tests low. *)

let test x = if not x then exit 1 else ()

let bomb msg =
  prerr_endline msg;
  exit 2

let _ =
  let fty = function_type void_type [| |] in
  let m = create_module "valid_m" in
  let fn = define_function "valid_fn" fty m in
  let at_entry = builder_at_end (entry_block fn) in
  ignore (build_ret_void at_entry);

  (* Test that valid constructs verify. *)
  match verify_module m with
    Some msg -> bomb "valid module failed verification!"
  | None -> ();

  if not (verify_function fn) then bomb "valid function failed verification!";

  (* Test that invalid constructs do not verify.
     A basic block can contain only one terminator instruction. *)
  ignore (build_ret_void at_entry);

  match verify_module m with
    Some msg -> ()
  | None -> bomb "invalid module passed verification!";

  if verify_function fn then bomb "invalid function passed verification!";

  dispose_module m

  (* Don't bother to test assert_valid_{module,function}. *)

Fix a typo noticed by Alain Frisch.

(* RUN: %ocamlc llvm.cma llvm_analysis.cma %s -o %t
 * RUN: ./%t %t.bc
 *)

open Llvm
open Llvm_analysis

(* Note that this takes a moment to link, so it's best to keep the number of
   individual tests low. *)

let test x = if not x then exit 1 else ()

let bomb msg =
  prerr_endline msg;
  exit 2

let _ =
  let fty = function_type void_type [| |] in
  let m = create_module "valid_m" in
  let fn = define_function "valid_fn" fty m in
  let at_entry = builder_at_end (entry_block fn) in
  ignore (build_ret_void at_entry);

  (* Test that valid constructs verify. *)
  begin match verify_module m with
    Some msg -> bomb "valid module failed verification!"
  | None -> ()
  end;

  if not (verify_function fn) then bomb "valid function failed verification!";

  (* Test that invalid constructs do not verify.
     A basic block can contain only one terminator instruction. *)
  ignore (build_ret_void at_entry);

  begin match verify_module m with
    Some msg -> ()
  | None -> bomb "invalid module passed verification!"
  end;

  if verify_function fn then bomb "invalid function passed verification!";

  dispose_module m

  (* Don't bother to test assert_valid_{module,function}. *)


(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

(** Relational abstract domain, elements of which are interpreted as Hoare
    triples over a base domain *)

module type State_domain_sig = sig
  include Domain_intf.Dom

  val create_summary :
       locals:Reg.Set.t
    -> formals:Reg.Set.t
    -> entry:t
    -> current:t
    -> summary * t
end

module Make (State_domain : State_domain_sig) : Domain_intf.Dom

Remove unused functor arg name

(*
 * Copyright (c) Facebook, Inc. and its affiliates.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the root directory of this source tree.
 *)

(** Relational abstract domain, elements of which are interpreted as Hoare
    triples over a base domain *)

module type State_domain_sig = sig
  include Domain_intf.Dom

  val create_summary :
       locals:Reg.Set.t
    -> formals:Reg.Set.t
    -> entry:t
    -> current:t
    -> summary * t
end

module Make (_ : State_domain_sig) : Domain_intf.Dom


open Js_of_ocaml
open Quasar_core.Util
open Jest
module J = Quasar_js

let arr str = Js.Unsafe.js_expr str

let empty_array () =
  test "Create an empty array" (fun () ->
      let expected : 'a J.Array.t = arr "[]" in
      let input = J.Array.empty () in
      (expect input).%{to_strict_equal} <- expected)
;;

let init1 () =
  test "Create an array using init" (fun () ->
      let expected : int J.Array.t = arr "[0, 1, 2, 3, 4, 5]" in
      let input = J.Array.init 6 (fun x -> x) in
      (expect input).%{to_strict_equal} <- expected)
;;

let suite () = List.iter (fun t -> t ()) [ empty_array; init1 ]

Add test for empty init

open Js_of_ocaml
open Quasar_core.Util
open Jest
module J = Quasar_js

let arr str = Js.Unsafe.js_expr str

let empty_array () =
  test "Create an empty array" (fun () ->
      let expected : 'a J.Array.t = arr "[]" in
      let input = J.Array.empty () in
      (expect input).%{to_strict_equal} <- expected)
;;

let init1 () =
  test "Create an array using init - 1" (fun () ->
      let expected : int J.Array.t = arr "[0, 1, 2, 3, 4, 5]" in
      let input = J.Array.init 6 (fun x -> x) in
      (expect input).%{to_strict_equal} <- expected)
;;

let init2 () =
  test "Create an array using init - 2" (fun () ->
      let expected : int J.Array.t = arr "[]" in
      let input = J.Array.init 0 (fun x -> x) in
      (expect input).%{to_strict_equal} <- expected)
;;

let suite () = List.iter (fun t -> t ()) [ empty_array; init1; init2 ]


(** domain of the base analysis *)

open Cil

module VD = ValueDomain.Compound

module CPA =
struct
  include MapDomain.MapBot_LiftTop (Basetype.Variables) (VD)
  let name () = "value domain"
end

module Flag =
struct
  include ConcDomain.SimpleThreadDomain
  let name () = "flag domain"
end

let heap_hash = Hashtbl.create 113

let get_heap_var loc =
  try Hashtbl.find heap_hash loc
  with Not_found ->
    let name = "(alloc@" ^ loc.file ^ ":" ^ string_of_int loc.line ^ ")" in
    let newvar = makeGlobalVar name voidType in
    Hashtbl.add heap_hash loc newvar;
    newvar

module Glob =
struct
  module Var = Basetype.Variables
  module Val = VD
end

module VarSet = SetDomain.Make(Basetype.Variables)
module VarMap = MapDomain.MapBot(Basetype.Variables)(VarSet)

module Dom = Lattice.Prod3(CPA)(Flag)(VarMap)

Switch to MapBot_LiftTop to solve issue when analyses is run w/o context and \top is generated for his map

(** domain of the base analysis *)

open Cil

module VD = ValueDomain.Compound

module CPA =
struct
  include MapDomain.MapBot_LiftTop (Basetype.Variables) (VD)
  let name () = "value domain"
end

module Flag =
struct
  include ConcDomain.SimpleThreadDomain
  let name () = "flag domain"
end

let heap_hash = Hashtbl.create 113

let get_heap_var loc =
  try Hashtbl.find heap_hash loc
  with Not_found ->
    let name = "(alloc@" ^ loc.file ^ ":" ^ string_of_int loc.line ^ ")" in
    let newvar = makeGlobalVar name voidType in
    Hashtbl.add heap_hash loc newvar;
    newvar

module Glob =
struct
  module Var = Basetype.Variables
  module Val = VD
end

module VarSet = SetDomain.Make(Basetype.Variables)
module VarMap = MapDomain.MapBot_LiftTop(Basetype.Variables)(VarSet)

module Dom = Lattice.Prod3(CPA)(Flag)(VarMap)


let rec find p xs =
    match xs with
    | [] -> None
    | x :: xs' -> if (p x) then (Some x)
                  else find p xs'

let rec remove p xs =
    match xs with
    | [] -> []
    | x :: xs' -> if (p x) then xs'
                  else x :: (remove p xs')

let rec replace p x xs =
    match xs with
    | [] -> []
    | x' :: xs' -> if (p x') then x :: xs'
                   else x' :: (replace p x xs')

Add insert_before and insert_after functions to Vylist. They will be used in node reordering.

let rec find p xs =
    match xs with
    | [] -> None
    | x :: xs' -> if (p x) then (Some x)
                  else find p xs'

let rec remove p xs =
    match xs with
    | [] -> []
    | x :: xs' -> if (p x) then xs'
                  else x :: (remove p xs')

let rec replace p x xs =
    match xs with
    | [] -> []
    | x' :: xs' -> if (p x') then x :: xs'
                   else x' :: (replace p x xs')

let rec insert_before p x xs =
    match xs with
    | [] -> raise Not_found
    | y :: ys -> if (p y) then x :: y :: ys
                 else y :: (insert_before p x ys)

let rec insert_after p x xs =
    match xs with
    | [] -> raise Not_found
    | y :: ys -> if (p y) then y :: x :: ys
                 else y :: (insert_after p x ys)


module G : Graph.Sig.G
  with type V.t = Llvm.llbasicblock

module Map (B : Graph.Builder.S) : sig

  val map :
    vertex:(G.vertex -> B.G.vertex) ->
    label:(G.edge -> B.G.E.label) ->
    ?src:(G.E.vertex -> B.G.E.vertex) ->
    ?dst:(G.E.vertex -> B.G.E.vertex) ->
    G.t -> (G.vertex -> B.G.vertex) * B.G.t

end

Fix interface and add a little bit of documentation.

(** Read only ocamlgraph interface for the control-flow-graph of llvm functions. *)

(** Graph of an llvm function.

    Warning : {!map_vertex} is not implemented! *)
module G : Graph.Sig.G
  with type t = Llvm.llvalue
   and type V.t = Llvm.llbasicblock
   and type E.label = unit

(** Mapping from Llvm's control flow graph to another graph. *)
module Map (B : Graph.Builder.S) : sig

  val map :
    vertex:(G.vertex -> B.G.vertex) ->
    label:(G.edge -> B.G.E.label) ->
    ?src:(G.E.vertex -> B.G.E.vertex) ->
    ?dst:(G.E.vertex -> B.G.E.vertex) ->
    G.t -> (G.vertex -> B.G.vertex) * B.G.t

end


let updater ms f =
  let ms' = float ms in
  let rec timeout_id = ref (lazy (Dom_html.window ## setTimeout (Js.wrap_callback loop, ms')))
  and loop ev =
    Dom_html.window ## clearTimeout (Lazy.force !timeout_id);
    let () = f () in
    timeout_id := (lazy Dom_html.window ## setTimeout (Js.wrap_callback loop, ms'));
    ignore (Lazy.force !timeout_id);
  in
  ignore (Lazy.force !timeout_id)

let create w prop updater =
  let signal, send = React.S.create (prop w) in
  updater (fun () -> send (prop w));
  signal

let time ?(accuracy=0.01) ?(start=0.) () =
  let time = ref start in
  let signal, send = React.S.create !time in
  updater (int_of_float (accuracy *. 1000.)) (fun () ->
    time := !time +. accuracy;
    send !time);
  signal

Add delay combinator to Time module

let updater ms f =
  let ms' = float ms in
  let rec timeout_id = ref (lazy (Dom_html.window ## setTimeout (Js.wrap_callback loop, ms')))
  and loop ev =
    Dom_html.window ## clearTimeout (Lazy.force !timeout_id);
    let () = f () in
    timeout_id := (lazy Dom_html.window ## setTimeout (Js.wrap_callback loop, ms'));
    ignore (Lazy.force !timeout_id);
  in
  ignore (Lazy.force !timeout_id)

let create w prop updater =
  let signal, send = React.S.create (prop w) in
  updater (fun () -> send (prop w));
  signal

let time ?(accuracy=0.01) ?(start=0.) () =
  let time = ref start in
  let signal, send = React.S.create !time in
  updater (int_of_float (accuracy *. 1000.)) (fun () ->
    time := !time +. accuracy;
    send !time);
  signal

let delay s =
  let accuracy = 10. in
  let time = ref 0. in
  fun ms ->
  let pending = Queue.create () in
  let news, send = React.S.create None in
  let send _ =
    time := !time +. 10.;
    let rec loop () =
      try
      (match Queue.peek pending with
          (t, s) ->
            if t < !time -. ms then
              begin
                let (_,s) = Queue.pop pending in
                send (Some s);
                loop ()
              end)
      with Queue.Empty -> ()
    in
      loop ()
  in
  let rec timeout_id = ref (lazy (Dom_html.window ## setTimeout (Js.wrap_callback (loop send), accuracy)))
  and loop f ev =
    f ();
    timeout_id := (lazy Dom_html.window ## setTimeout (Js.wrap_callback (loop send), accuracy));
    ignore (Lazy.force !timeout_id);
  in
    ignore (Lazy.force !timeout_id);
    React.S.l1 (fun x -> Queue.add (!time, x) pending) s;
    React.S.fmap (fun x -> x) (React.S.value s) news


(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

open Pervasiveext
open Client

let rpc xml =
    let open Xmlrpc_client in
    XML_protocol.rpc ~transport:(Unix "/var/xapi/xapi") ~http:(xmlrpc ~version:"1.0" "/") xml

let _ =
    let session_id = Client.Session.login_with_password ~rpc ~uname:"" ~pwd:"" ~version:"1.0" in
	finally
		(fun () -> Create_templates.create_all_templates rpc session_id)
		(fun () -> Client.Session.logout rpc session_id)

Switch to rpc-light based XenAPI client.

(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

open Pervasiveext
open Client

let rpc xml =
    let open Xmlrpc_client in
    XMLRPC_protocol.rpc ~transport:(Unix "/var/xapi/xapi") ~http:(xmlrpc ~version:"1.0" "/") xml

let _ =
    let session_id = Client.Session.login_with_password ~rpc ~uname:"" ~pwd:"" ~version:"1.0" in
	finally
		(fun () -> Create_templates.create_all_templates rpc session_id)
		(fun () -> Client.Session.logout rpc session_id)


(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

open Xcp_service
module D = Debug.Make(struct let name = "ffs" end)
open D

open Server

let losetup = ref "/sbin/losetup"

let resources = [
  { Xcp_service.name = "losetup";
    description = "used to set up loopback block devices";
    essential = true;
    path = losetup;
    perms = [ Unix.X_OK ];
  }
]

let main () =
  debug "%s version %d.%d starting" name major_version minor_version;

  configure ~resources ();
  let socket = listen !Storage_interface.default_path in
  daemonize ();

  accept_forever socket
    (fun s ->
      http_handler Xmlrpc.call_of_string Xmlrpc.string_of_response Server.process s ()
    );

  wait_forever ()

let _ = main ()

Allow the listening socket to be configured via the commandline/config file

(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

open Xcp_service
module D = Debug.Make(struct let name = "ffs" end)
open D

open Server

let losetup = ref "/sbin/losetup"

let resources = [
  { Xcp_service.name = "losetup";
    description = "used to set up loopback block devices";
    essential = true;
    path = losetup;
    perms = [ Unix.X_OK ];
  }
]

let socket_path = ref !Storage_interface.default_path

let options = [
  "socket-path", Arg.Set_string socket_path, (fun () -> !socket_path), "Path of listening socket";
]

let main () =
  debug "%s version %d.%d starting" name major_version minor_version;

  configure ~options ~resources ();
  let socket = listen !socket_path in
  if !Xcp_service.daemon then daemonize ();

  accept_forever socket
    (fun s ->
      http_handler Xmlrpc.call_of_string Xmlrpc.string_of_response Server.process s ()
    );

  wait_forever ()

let _ = main ()


(*
formulatop -I $CAMLLIB_INSTALL/lib -I $MLCUDDIDL_INSTALL/lib
*)

open Format;;

let cudd = Cudd.Man.make_d ();;
Cudd.Man.print_limit := 200;;
Cudd.Man.set_gc 10000
  (begin fun () -> printf "@.CUDD GC@." end)
  (begin fun () -> printf "@.CUDD REORDER@." end)
;;
let env = BdddomainE.make_env cudd;;
env#add_typ "enum2" (`Benum [|"l1"; "l2"; "l3"|]);;
env;;
env#add_vars [
  ("q1",`Bint(false,3));
  ("q2",`Bint(false,3));
  ("e",`Benum("enum2"));
  ("b0",`Bool);
  ("b1",`Bool);
  ("b2",`Bool);
  ("b3",`Bool);
];;
env;;

let expr = BddexprE.Bool.var env "b0";;
printf "%a@." BddexprE.Bool.print expr;;

Update because of new interface.

(*
bddtop -I $CAMLLIB_INSTALL/lib -I $MLCUDDIDL_INSTALL/lib
*)

open Format;;

let cudd = Cudd.Man.make_d ();;
Cudd.Man.print_limit := 200;;
Cudd.Man.set_gc 10000
  (begin fun () -> printf "@.CUDD GC@." end)
  (begin fun () -> printf "@.CUDD REORDER@." end)
;;
let env = Bdd.Env.make cudd;;
env#add_typ "enum2" (`Benum [|"l1"; "l2"; "l3"|]);;
env;;
env#add_vars [
  ("q1",`Bint(false,3));
  ("q2",`Bint(false,3));
  ("e",`Benum("enum2"));
  ("b0",`Bool);
  ("b1",`Bool);
  ("b2",`Bool);
  ("b3",`Bool);
];;
env;;

let expr = Bdd.Expr1.Bool.var env "b0";;
printf "%a@." Bdd.Expr1.Bool.print expr;;


open Core.Std

let times_to_repeat = 40

let () =
  let require_line = (function
      | None -> failwith "input required"
      | Some line -> line) in
  In_channel.input_line stdin
  |> require_line
  |> MathSequence.iterate ~f:LookAndSay.next ~count:times_to_repeat
  |> String.length |> Int.to_string
  |> print_string

Complete day 10 part 2

open Core.Std

(* let times_to_repeat = 40 *)
let times_to_repeat = 50

let () =
  let require_line = (function
      | None -> failwith "input required"
      | Some line -> line) in
  In_channel.input_line stdin
  |> require_line
  |> MathSequence.iterate ~f:LookAndSay.next ~count:times_to_repeat
  |> String.length |> Int.to_string
  |> print_string


open Mirage

let main =
  main
    ~packages:[package "cohttp-mirage"]
    "Unikernel.Main" (conduit @-> job)

let () =
  register "conduit_server" [ main $ conduit_direct (generic_stackv4 default_network) ]

Upgrade conduit to use v4v6 stack

open Mirage

let main =
  main
    ~packages:[package "cohttp-mirage"]
    "Unikernel.Main" (conduit @-> job)

let () =
  register "conduit_server" [ main $ conduit_direct (generic_stackv4v6 default_network) ]


let log_path = "/var/log/fe.log"

let debug_log = ref []

let gettimestring () =
	let time = Unix.gettimeofday () in
	let tm = Unix.gmtime time in
        let msec = time -. (floor time) in
	Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 + tm.Unix.tm_year)
	        (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
	        tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
	        (int_of_float (1000.0 *. msec))

let reset () = debug_log := []

let debug (fmt : ('a, unit, string, unit) format4) =
  Printf.kprintf (fun s -> debug_log := Printf.sprintf "%s|%d|%s\n" (gettimestring ()) (Unix.getpid ()) s :: !debug_log) fmt

let write_log () =
  List.iter (Syslog.log Syslog.Syslog Syslog.Err) (List.rev !debug_log)

Make the fe process flush its debug buffer when output to syslog

let log_path = "/var/log/fe.log"

let debug_log = ref []

let gettimestring () =
	let time = Unix.gettimeofday () in
	let tm = Unix.gmtime time in
        let msec = time -. (floor time) in
	Printf.sprintf "%d%.2d%.2dT%.2d:%.2d:%.2d.%.3dZ|" (1900 + tm.Unix.tm_year)
	        (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
	        tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
	        (int_of_float (1000.0 *. msec))

let reset () = debug_log := []

let debug (fmt : ('a, unit, string, unit) format4) =
  Printf.kprintf (fun s -> debug_log := Printf.sprintf "%s|%d|%s\n" (gettimestring ()) (Unix.getpid ()) s :: !debug_log) fmt

let write_log () =
  List.iter (Syslog.log Syslog.Syslog Syslog.Err) (List.rev !debug_log);
  reset ()


(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

let init _ _ = ()
let log_if_initialized _ = ()
let master_exception _ = ()
let worker_exception _ = ()
let sharedmem_gc_ran _ _ _ _ = ()
let sharedmem_init_done _ = ()
let sharedmem_failed_anonymous_memfd_init _ = ()
let sharedmem_failed_to_use_shm_dir ~shm_dir:_ ~reason:_ = ()
let sharedmem_less_than_minimum_available
  ~shm_dir:_
  ~shm_min_avail:_
  ~avail:_ = ()
let find_done ~time_taken:_ ~name:_ = ()
let log_gc_stats () = ()
let flush _ = ()
let watchman_error _ = ()
let watchman_warning _ = ()
let watchman_timeout _ = ()
let dfind_ready _ _ = ()

Reduce duplicated system info logged to Scuba

(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

let init ?init_id:_ _ _ = ()
let log_if_initialized _ = ()
let master_exception _ = ()
let worker_exception _ = ()
let sharedmem_gc_ran _ _ _ _ = ()
let sharedmem_init_done _ = ()
let sharedmem_failed_anonymous_memfd_init _ = ()
let sharedmem_failed_to_use_shm_dir ~shm_dir:_ ~reason:_ = ()
let sharedmem_less_than_minimum_available
  ~shm_dir:_
  ~shm_min_avail:_
  ~avail:_ = ()
let find_done ~time_taken:_ ~name:_ = ()
let log_gc_stats () = ()
let flush _ = ()
let watchman_error _ = ()
let watchman_warning _ = ()
let watchman_timeout _ = ()
let dfind_ready _ _ = ()


open Gstreamer

let () =
  init ();
  Printf.printf "%s\n%!" (version_string ());
  let bin = Pipeline.parse_launch "audiotestsrc ! audioconvert ! audioresample ! osssink" in
    ignore (Element.set_state bin State_playing);
    Unix.sleep 5;
    ignore (Element.set_state bin State_null);
    Gc.full_major ()

Clean setting for debug level.

open Gstreamer

let () =
  init ();
  Printf.printf "%s\n%!" (version_string ());
  let bin = Pipeline.parse_launch "audiotestsrc ! audioconvert ! audioresample ! osssink" in
    ignore (Element.set_state bin State_playing);
    Unix.sleep 5;
    ignore (Element.set_state bin State_null);
    Gstreamer.deinit ();
    Gc.full_major ()


(* OASIS_START *)
(* OASIS_STOP *)

let _ =
  Ocamlbuild_plugin.dispatch
    (fun hook ->
       dispatch_default hook;
       match hook with
       | After_rules ->
           (* Internal syntax extension *)
           List.iter
             (fun dir ->
                let tag = "use_pa_deriving_" ^ dir and file = "syntax/" ^ dir ^ "/pa_deriving_" ^ dir ^ ".cma" in
                flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file];
                flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file];
                flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file];
                dep ["ocaml"; "ocamldep"; tag] [file])
             ["common"; "std"; "tc"; "classes"];
       | _ -> ())

Configure ocamlbuild to select the right ocamlfind

(* OASIS_START *)
(* OASIS_STOP *)

let _ =

  (* FIX START *)
  (* fix needed by ocaml(build) 3.12.1(,4.00.1?) in order to pick the right ocamlfind *)

  (* Fixed in later version with the following commit *)
  (* ocamlbuild should look for ocamlfind on the path not in the root directory *)
  (* https://github.com/ocaml/ocaml/commit/9d51dccfaebb2c3303ae0bb1d4f28fe6f8d10915 *)

  let _ = Ocamlbuild_pack.Ocamlbuild_where.bindir := "/" in
  (* FIX STOP *)

  Ocamlbuild_plugin.dispatch
    (fun hook ->
       dispatch_default hook;
       match hook with
       | After_rules ->
           (* Internal syntax extension *)
           List.iter
             (fun dir ->
                let tag = "use_pa_deriving_" ^ dir and file = "syntax/" ^ dir ^ "/pa_deriving_" ^ dir ^ ".cma" in
                flag ["ocaml"; "compile"; tag] & S[A"-ppopt"; A file];
                flag ["ocaml"; "ocamldep"; tag] & S[A"-ppopt"; A file];
                flag ["ocaml"; "doc"; tag] & S[A"-ppopt"; A file];
                dep ["ocaml"; "ocamldep"; tag] [file])
             ["common"; "std"; "tc"; "classes"];
       | _ -> ())


(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

module Rpc : Rrdd_interface.RPC = Rpc_retry.Make(
	struct
		let client_name = "xapi"
		let server_name = Rrdd_interface.name
		let server_path = Filename.concat Fhs.vardir Rrdd_interface.name
		let should_retry = false
	end
)
module Client = Rrdd_interface.Client(Rpc)

(* Make the interface available directly to anyone using this module.*)
include Client

Rewrite Rrdd_client to use the standard xcp helpers

(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)

let rec retry_econnrefused f =
  try
    f ()
  with
  | Unix.Unix_error(Unix.ECONNREFUSED, "connect", _) ->
      (* debug "Caught ECONNREFUSED; retrying in 5s"; *)
      Thread.delay 5.;
      retry_econnrefused f
  | e ->
      (* error "Caught %s: does the rrdd service need restarting?" (Printexc.to_string e); *)

      raise e

module Client = Rrdd_interface.Client(struct
  let rpc =
    retry_econnrefused
      (fun () ->
        Xcp_client.xml_http_rpc
          ~srcstr:(Xcp_client.get_user_agent ())
          ~dststr:"rrdd"
          (fun () -> Rrdd_interface.uri)
      )
end)


(*
 * Copyright (c) 2016 Jeremy Yallop.
 *
 * This file is distributed under the terms of the MIT License.
 * See the file LICENSE for details.
 *)

(* Foreign function bindings for the Lwt jobs tests. *)

open Ctypes

module Stubs (F: Cstubs.FOREIGN) =
struct
  open F

  let sqrt = foreign "sqrt" (double @-> returning double)

  let sum_int_array = foreign "sum_int_array"
      (ptr int32_t @-> size_t @-> returning int32_t)
end

Test Lwt ML code generation for non-trivial return types.

(*
 * Copyright (c) 2016 Jeremy Yallop.
 *
 * This file is distributed under the terms of the MIT License.
 * See the file LICENSE for details.
 *)

(* Foreign function bindings for the Lwt jobs tests. *)

open Ctypes

module Stubs (F: Cstubs.FOREIGN) =
struct
  open F

  let sqrt = foreign "sqrt" (double @-> returning double)

  let sum_int_array = foreign "sum_int_array"
      (ptr int32_t @-> size_t @-> returning int32_t)

  let realpath = foreign "realpath"
      (string @-> string @-> returning string)
end


(*
 * Copyright (c) 2013-2017 Thomas Gazagnaire <thomas@gazagnaire.org>
 * and Romain Calascibetta <romain.calascibetta@gmail.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

(** The Git Reference module. *)

end

end

Reduce the intf. of Reference and parameter [head_contents]/[contents] with an ['hash] type.

(*
 * Copyright (c) 2013-2017 Thomas Gazagnaire <thomas@gazagnaire.org>
 * and Romain Calascibetta <romain.calascibetta@gmail.com>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)
open Carton

(** The Git Reference module. *)
type t

val of_string : string -> (t, [> `Msg of string ]) result

val v : string -> t

val add_seg : t -> string -> t

val append : t -> t -> t

val segs : t -> string list

val pp : t Fmt.t

val head : t

val master : t

val ( / ) : t -> string -> t

val ( // ) : t -> t -> t

val to_string : t -> string

val equal : t -> t -> bool

val compare : t -> t -> int

module Map : Map.S with type key = t

module Set : Set.S with type elt = t

type 'uid contents = Uid of 'uid | Ref of t

val equal_contents :
  equal:('uid -> 'uid -> bool) -> 'uid contents -> 'uid contents -> bool

val compare_contents :
  compare:('uid -> 'uid -> int) -> 'uid contents -> 'uid contents -> int

val pp_contents : pp:'uid Fmt.t -> 'uid contents Fmt.t

val uid : 'uid -> 'uid contents

val ref : t -> 'uid contents

end

end


let xe = Eventchn.init ()
let nr_events = 1024
let event_cb = Array.init nr_events (fun _ -> Lwt_sequence.create ())

let wait port =
  let th, u = Lwt.task () in
  let node = Lwt_sequence.add_r u event_cb.(Eventchn.to_int port) in
  Lwt.on_cancel th (fun _ -> Lwt_sequence.remove node);
  th

let wake port =
	Lwt_sequence.iter_node_l (fun node ->
		let u = Lwt_sequence.get node in
		Lwt_sequence.remove node;
		Lwt.wakeup u ()
    ) event_cb.(port)

(* Go through the event mask and activate any events, potentially spawning
   new threads *)
let run () =
	let fd = Lwt_unix.of_unix_file_descr ~blocking:false ~set_flags:true (Eventchn.fd xe) in
	let rec inner () =
		lwt () = Lwt_unix.wait_read fd in
	    let port = Eventchn.pending xe in
		wake (Eventchn.to_int port);
		Eventchn.unmask xe port;
        inner ()
   in inner ()

Remove the top-level binding which called Eventchn.init

let nr_events = 1024
let event_cb = Array.init nr_events (fun _ -> Lwt_sequence.create ())

let wait port =
  let th, u = Lwt.task () in
  let node = Lwt_sequence.add_r u event_cb.(Eventchn.to_int port) in
  Lwt.on_cancel th (fun _ -> Lwt_sequence.remove node);
  th

let wake port =
	Lwt_sequence.iter_node_l (fun node ->
		let u = Lwt_sequence.get node in
		Lwt_sequence.remove node;
		Lwt.wakeup u ()
    ) event_cb.(port)

(* Go through the event mask and activate any events, potentially spawning
   new threads *)
let run () =
	let xe = Eventchn.init () in
	let fd = Lwt_unix.of_unix_file_descr ~blocking:false ~set_flags:true (Eventchn.fd xe) in
	let rec inner () =
		lwt () = Lwt_unix.wait_read fd in
	    let port = Eventchn.pending xe in
		wake (Eventchn.to_int port);
		Eventchn.unmask xe port;
        inner ()
   in inner ()


open Mirage

let main = foreign "Unikernel.Main" (console @-> network @-> job)

let () =
  add_to_ocamlfind_libraries
    [ "tcpip.ethif"; "tcpip.ipv4"; "mirage-clock-unix" ];

  register "ping" [
    main $ default_console $ tap0
  ]

Remove mirage-clock-unix from ping test

open Mirage

let main = foreign "Unikernel.Main" (console @-> network @-> job)

let () =
  add_to_ocamlfind_libraries [ "tcpip.ethif"; "tcpip.ipv4" ];
  register "ping" [ main $ default_console $ tap0 ]


module X : sig
  val x : int [@@deprecated "DEPRECATED"]
end = struct
  let x = 7
end

module Y : sig val x : int end = X

module Z : sig val x : int [@@deprecated "..."] end = X

module F(A : sig val x : int end) = struct end

module B = F(X)

Check that extra deprecated attributes can be added during module coercion.

module X : sig
  val x : int [@@deprecated "DEPRECATED"]
end = struct
  let x = 7
end

module Y : sig val x : int end = X

module Z : sig val x : int [@@deprecated "..."] end = X

module F(A : sig val x : int end) = struct end

module B = F(X)

module XX = struct let x = 7 end
module YY : sig val x : int [@@deprecated "..."] end = XX


open Util
open Common

let () =
  let open Mas_parser in
  let file = if Array.length Sys.argv < 2 then "A_gen" else Sys.argv.(1) in
  let mp = from_file (Common.to_alignment_file file) in
  List.iter mp.alt_elems ~f:(fun (al1, allele) ->
    let ds = allele_distances ~reference:mp.ref_elems ~allele
            |> List.map ~f:(fun d -> sprintf "%d" d.mismatches)
            |> String.concat ~sep:";"
    in
    printf "ref vs %s: %s\n" al1 ds;
    List.iter mp.alt_elems ~f:(fun (al2, allele2) ->
      let dvs =
        allele_distances_between ~reference:mp.ref_elems
          ~allele1:allele ~allele2
        |> List.map ~f:(fun d -> sprintf "%d" d.mismatches)
        |> String.concat ~sep:";"
      in
      printf " %s vs %s: %s\n" al1 al2 dvs))

Add a check for interactive mode

open Util
open Common

let () =
  if !Sys.interactive then () else
    let open Mas_parser in
    let n = Array.length Sys.argv in
    let file = if n < 2 then "A_gen" else Sys.argv.(1) in
    let mp = from_file (Common.to_alignment_file file) in
    List.iter mp.alt_elems ~f:(fun (al1, allele) ->
      let ds = allele_distances ~reference:mp.ref_elems ~allele
              |> List.map ~f:(fun d -> sprintf "%d" d.mismatches)
              |> String.concat ~sep:";"
      in
      printf "ref vs %s: %s\n" al1 ds;
      List.iter mp.alt_elems ~f:(fun (al2, allele2) ->
        let dvs =
          allele_distances_between ~reference:mp.ref_elems
            ~allele1:allele ~allele2
          |> List.map ~f:(fun d -> sprintf "%d" d.mismatches)
          |> String.concat ~sep:";"
        in
        printf " %s vs %s: %s\n" al1 al2 dvs))


open V1_LWT

let (>>=) = Lwt.bind

module Main (C:CONSOLE) = struct
  let buf = String.create 5000

  let rec echo vch =
    Node.V.read_into vch buf 0 5000 >>= fun nb_read ->
    Node.V.write_from_exactly vch buf 0 nb_read >>= fun () ->
    echo vch

  let start c =
    lwt () = Node.with_vchan Node.Server (Eventchn.init ()) 0 "data/vchan" echo in
    Lwt.return ()

end

Update the test VM to use the flow signature

open V1_LWT

let (>>=) = Lwt.bind

let (>>|=) m f = m >>= function
| `Ok x -> f x
| `Eof -> Lwt.fail (Failure "End of file")
| `Error (`Not_connected state) -> Lwt.fail (Failure (Printf.sprintf "Not in a connected state: %s" (Sexplib.Sexp.to_string (Node.V.sexp_of_state state))))

module Main (C:CONSOLE) = struct
  let buf = String.create 5000

  let rec echo vch =
    Node.V.read vch >>|= fun input_line ->
    let line = String.uppercase (Cstruct.to_string input_line) in
    let buf = Cstruct.create (String.length line) in
    Cstruct.blit_from_string line 0 buf 0 (String.length line);
    Node.V.write vch buf >>|= fun () ->
    echo vch

  let start c =
    lwt () = Node.with_vchan Node.Server (Eventchn.init ()) 0 "data/vchan" echo in
    Lwt.return ()

end


let dir = Sys.argv.(1)

let write f =
  let path = Filename.concat dir f in
  let out = open_out path in
  output_string out (f ^ " contents\n");
  close_out_noerr out

let () =
  Unix.mkdir dir 0o777;
  write "foo";
  write "bar"

Make the dir-target-dep test more reproducible

let () = Printexc.record_backtrace false

let dir = Sys.argv.(1)

let write f =
  let path = Filename.concat dir f in
  let out = open_out path in
  output_string out (f ^ " contents\n");
  close_out_noerr out

let () =
  Unix.mkdir dir 0o777;
  write "foo";
  write "bar"


open Cil

;;

initCIL ();

let variable = makeGlobalVar "value" intType in

let instructions = ref [] in
for loop = 1 to 25000 do
  let instruction = Set(var variable, integer loop, locUnknown) in
  instructions := instruction :: !instructions
done;

let statement = mkStmt (Instr !instructions) in
dumpStmt defaultCilPrinter stdout 0 statement

Revise the long statement block test to print the block into /dev/null instead of stdout. We don't really want 25,000 lines of C code to appear in the test log once this bug gets fixed.

open Cil

;;

initCIL ();

let variable = makeGlobalVar "value" intType in

let instructions = ref [] in
for loop = 1 to 25000 do
  let instruction = Set(var variable, integer loop, locUnknown) in
  instructions := instruction :: !instructions
done;

let statement = mkStmt (Instr !instructions) in
let sink = open_out "/dev/null" in
dumpStmt defaultCilPrinter sink 0 statement


(* Auxiliary types *)
type type_name = string
type type_binders = type_name list

(* Kind definition *)

(* An atom cannot be parametrized by types. *)
(* kind List[A]: type *)
(* kind Bool: type is equivalent to kind Bool[]: type *)
type kind =
  | Type of type_binders
  | Atom

(* Type application *)

type polymorphic_arg =
  | RawType of type_name
  | AnyType (* Underscore representation for any type (e.g. List[_]) *)

(* A type application is the process to apply a type to another. *)
type type_application = type_name * polymorphic_arg list

(* Constant definition *)

type constant = type_binders * type_application

(* Operator definition *)

(* A binder is: "Variable" in Variable . Term * Term -> Term.
 (Note the '.' that delimitate the binder). *)
type binder = type_name option
type operator_args = type_application list
type operator_result = type_name

type operator = type_binders * binder * operator_args * operator_result

(* Rule definition *)

type pattern =
  | POperator of string * pattern list
  | PPlaceholder of string
  | PConstant of string

type effect =
  | EOperator of string * effect list
  | EPlaceholder of string
  | EConstant of string

type rule = pattern * effect

(* rewriting system *)
type rewriting_system = kind list * constant list * operator list * rule list (* maybe + the symbol table ? *)

Update the AST with comments of the mailing list.

(* Auxiliary types *)
type type_name = string
type type_binders = type_name list

(* Kind definition *)

(* An atom cannot be parametrized by types. *)
(* kind List[A]: type *)
(* kind Bool: type is equivalent to kind Bool[]: type *)
type kind =
  | Type of type_binders
  | Atom

(* Type application *)

type polymorphic_arg =
  | RawType of type_name
  | AnyType (* Underscore representation for any type (e.g. List[_]) *)

(* A type application is the process to apply a type to another. *)
type type_application = type_name * polymorphic_arg list

(* Constant definition *)

type constant = type_binders * type_application

(* Operator definition *)

(* A binder is: "Variable" in Variable . Term * Term -> Term.
 (Note the '.' that delimitate the binder). *)
type binder = type_name option
type operator_args = type_application list
type operator_result = type_name

type operator = type_binders * binder * operator_args * operator_result

(* Rule definition *)

type pattern =
  | POperator of string * pattern list
  | PPlaceholder of string
  | PConstant of string
  | PAny

type effect =
  | EOperator of string * effect list
  | EPlaceholder of string
  | EConstant of string

type rule = pattern * effect

(* rewriting system *)
type info = Lexing.position
type 'a symbol_table = (string, 'a * info) Hashtbl.t
type rewriting_system =
  kind symbol_table *
  constant symbol_table *
  operator symbol_table *
  rule symbol_table


(* An advanced implementation of and advanced algorithm. For a more civilized
 * age, where keeping secrets will not be necessary anymore.
 *
 * It includes a bcrypt-like work factor argument and even rejects
 * weak factors.
 *
 * Compile and run with:
     * ocamlc BKKCrypt.ml -o BKKCrypt && ./BKKCrypt
 *)
let rec bkkcrypt str work_factor =
    if work_factor < 20 then
        failwith "Work Factors below 20 are considered weak!"
    else
        str;;

assert ((bkkcrypt "hunter2" 20) = ("hunter2"));;
Printf.printf "Testing done, no errors detected! Code is production-ready\n";;

Enhance security of the OCaml implementation

(* An advanced implementation of and advanced algorithm. For a more civilized
 * age, where keeping secrets will not be necessary anymore.
 *
 * It includes a bcrypt-like work factor argument and even rejects
 * weak factors.
 *
 * Compile and run with:
     * ocamlc BKKCrypt.ml -o BKKCrypt && ./BKKCrypt
 *)
let rec bkkcrypt str work_factor =
    if work_factor < 1000 then
        failwith "Work Factors below 1000 are considered weak!"
    else
        str;;

assert ((bkkcrypt "hunter2" 1000) = ("hunter2"));;
Printf.printf "Testing done, no errors detected! Code is production-ready\n";;


open Stdune
open Action

include module type of struct include Action_dune_lang end

module Partial : sig
  include Action_intf.Ast
    with type program = (Unresolved.Program.t, String_with_vars.t) either
    with type path    = (Path.t              , String_with_vars.t) either
    with type string  = (String.t            , String_with_vars.t) either

  val expand
    :  t
    -> map_exe:(Path.t -> Path.t)
    -> expander:Expander.t
    -> Unresolved.t
end

val partial_expand
  :  t
  -> map_exe:(Path.t -> Path.t)
  -> expander:Expander.t
  -> Partial.t

val remove_locs : t -> t

(** Infer dependencies and targets.

    This currently doesn't support well (rename ...) and (remove-tree ...). However these
    are not exposed in the DSL.
*)
module Infer : sig
  module Outcome : sig
    type t =
      { deps    : Path.Set.t
      ; targets : Path.Set.t
      }
  end

  val infer : Action.t -> Outcome.t

  (** If [all_targets] is [true] and a target cannot be determined statically, fail *)
  val partial : all_targets:bool -> Partial.t -> Outcome.t

  (** Return the list of targets of an unexpanded action. *)
  val unexpanded_targets : t -> String_with_vars.t list
end

Remove opan Action in Action_unexpanded

open Stdune

include module type of struct include Action_dune_lang end

module Partial : sig
  include Action_intf.Ast
    with type program = (Action.Unresolved.Program.t, String_with_vars.t) either
    with type path    = (Path.t                     , String_with_vars.t) either
    with type string  = (String.t                   , String_with_vars.t) either

  val expand
    :  t
    -> map_exe:(Path.t -> Path.t)
    -> expander:Expander.t
    -> Action.Unresolved.t
end

val partial_expand
  :  t
  -> map_exe:(Path.t -> Path.t)
  -> expander:Expander.t
  -> Partial.t

val remove_locs : t -> t

(** Infer dependencies and targets.

    This currently doesn't support well (rename ...) and (remove-tree ...). However these
    are not exposed in the DSL.
*)
module Infer : sig
  module Outcome : sig
    type t =
      { deps    : Path.Set.t
      ; targets : Path.Set.t
      }
  end

  val infer : Action.t -> Outcome.t

  (** If [all_targets] is [true] and a target cannot be determined statically, fail *)
  val partial : all_targets:bool -> Partial.t -> Outcome.t

  (** Return the list of targets of an unexpanded action. *)
  val unexpanded_targets : t -> String_with_vars.t list
end


(**
 * Copyright (c) 2014, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "flow" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

type logging_context = {
  argv: string;
  command: string option;
  from: string option;
  root: string option;
  start_time: float;
}

let get_context _ = {
  argv = "";
  command = None;
  from = None;
  root = None;
  start_time = 0.0;
}
let set_command _ = ()
let set_from _ = ()
let set_root _ = ()

let status_response _ = ()
let init_server _ = ()
let init_done _ = ()
let init_flow_command _ = ()
let killed _ = ()
let lock_lost _ = ()
let lock_stolen _ = ()
let out_of_date _ = ()
let autocomplete_member_result _ _ _ = ()

Update logger stub and fix OSS build

(**
 * Copyright (c) 2014, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the BSD-style license found in the
 * LICENSE file in the "flow" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

type logging_context = {
  argv: string;
  command: string option;
  from: string option;
  root: string option;
  start_time: float;
}

let get_context _ = {
  argv = "";
  command = None;
  from = None;
  root = None;
  start_time = 0.0;
}
let set_command _ = ()
let set_from _ = ()
let set_root _ = ()

let status_response _ = ()
let init_server _ = ()
let init_done _ = ()
let init_flow_command _ = ()
let killed _ = ()
let lock_lost _ = ()
let lock_stolen _ = ()
let out_of_date _ = ()
let autocomplete_member_result _ _ _ = ()
let exit _ _ = ()


open Prelude.Ana
open GobConfig
module Q = Queries

let is_global (a: Q.ask) (v: varinfo): bool =
  v.vglob || match a (Q.MayEscape v) with `MayBool tv -> tv | _ -> false

let is_static (v:varinfo): bool = v.vstorage == Static

let is_always_unknown variable = variable.vstorage = Extern || Ciltools.is_volatile_tp variable.vtype

let precious_globs = ref []
let is_precious_glob v = List.mem v.vname !precious_globs

let after_config () =
  precious_globs := List.map Json.string (get_list "exp.precious_globs")

let _ =
  AfterConfig.register after_config

Use structural equality for vstorage consistently

open Prelude.Ana
open GobConfig
module Q = Queries

let is_global (a: Q.ask) (v: varinfo): bool =
  v.vglob || match a (Q.MayEscape v) with `MayBool tv -> tv | _ -> false

let is_static (v:varinfo): bool = v.vstorage = Static

let is_always_unknown variable = variable.vstorage = Extern || Ciltools.is_volatile_tp variable.vtype

let precious_globs = ref []
let is_precious_glob v = List.mem v.vname !precious_globs

let after_config () =
  precious_globs := List.map Json.string (get_list "exp.precious_globs")

let _ =
  AfterConfig.register after_config


(* © 2014 RunOrg *)

open Std

module Create = Endpoint.Post(struct

  module Arg = type module unit
  module Post = type module <
    ?id    : string option ;
    ?label : string option ;
  >

  module Out = type module <
    id : Group.I.t ;
    at : Cqrs.Clock.t ;
  >

  let path = "groups/create"

  let response req () post =
    match Option.bind (post # id) CustomId.validate, post # id with
    | None, Some id -> return (`BadRequest (!! "%S is not a valid identifier" id))
    | id, _ -> let! id, at = Group.create ?id ?label:(post # label) () in
	       return (`OK (Out.make ~id ~at))

end)

module Delete = Endpoint.Delete(struct

  module Arg = type module < id : Group.I.t >
  module Out = type module < at : Cqrs.Clock.t >

  let path = "groups/{id}"

  let response req args =
    (* TODO: check for existence *)
    let! at = Group.delete (args # id) in
    return (`Accepted (Out.make ~at))

end)

Fix response status for "/groups/create"

(* © 2014 RunOrg *)

open Std

module Create = Endpoint.Post(struct

  module Arg = type module unit
  module Post = type module <
    ?id    : string option ;
    ?label : string option ;
  >

  module Out = type module <
    id : Group.I.t ;
    at : Cqrs.Clock.t ;
  >

  let path = "groups/create"

  let response req () post =
    match Option.bind (post # id) CustomId.validate, post # id with
    | None, Some id -> return (`BadRequest (!! "%S is not a valid identifier" id))
    | id, _ -> let! id, at = Group.create ?id ?label:(post # label) () in
	       return (`Accepted (Out.make ~id ~at))

end)

module Delete = Endpoint.Delete(struct

  module Arg = type module < id : Group.I.t >
  module Out = type module < at : Cqrs.Clock.t >

  let path = "groups/{id}"

  let response req args =
    (* TODO: check for existence *)
    let! at = Group.delete (args # id) in
    return (`Accepted (Out.make ~at))

end)


(*
 * Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open IrminLwt
open OUnit
open Test_common

let test_init () =
  clean test_db;
  IrminQueue.init (`Dir test_db)

let suite =
  "QUEUE" >:::
    [ "init" >:: test_init; ]

let () =
  run_tests suite

Add (failing) test for IrminQueue

(*
 * Copyright (c) 2013 Thomas Gazagnaire <thomas@gazagnaire.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open IrminLwt
open OUnit
open Test_common

let test_init () =
  clean test_db;
  IrminQueue.init (`Dir test_db)

let test_add_and_peek () =
  let t = `Dir test_db in
  let v1 = Value.blob "foo" in
  let v2 = Value.blob "" in
  IrminQueue.add t [v1; v2];
  let v1' = IrminQueue.peek t in
  assert_value_equal "v1" v1 v1'

let suite =
  "QUEUE" >:::
    [
      "Init a queue"                           >:: test_init;
      "Add elements to the queue and peek one" >:: test_add_and_peek;
    ]

let () =
  run_tests suite


module Default =
struct
  let default =
    [ `Multi_ack
    ; `Thin_pack
    ; `Side_band_64k
    ; `Ofs_delta
    ; `Agent "git/2.0.0"
    ; `Report_status
    ; `No_done ]
end

module Web_cohttp_lwt = Web_cohttp_lwt
module Cstruct_buffer = Cstruct_buffer

module Make
    (K : Git.Sync.CAPABILITIES)
    (C : Git.Sync_http.CLIENT
     with type +'a io = 'a Lwt.t
      and type headers = Web_cohttp_lwt.HTTP.headers
      and type body = unit -> (Cstruct.t * int * int) option Lwt.t
      and type meth = Web_cohttp_lwt.HTTP.meth
      and type uri = Web_cohttp_lwt.uri
      and type resp = Web_cohttp_lwt.resp)
    (S : Git.Minimal.S
     with type Hash.Digest.buffer = Cstruct.t
      and type Hash.hex = string)
  : Git.Sync_http.S
    with module Web    := Web_cohttp_lwt
     and module Client := C
     and module Store  := S
     and module Buffer := Cstruct_buffer
= struct
  include Git.Sync_http.Make(K)(Web_cohttp_lwt)(C)(S)(Cstruct_buffer)
end

Change multi_ack capabilities to multi_ack_detailed in the HTTP client

module Default =
struct
  let default =
    [ `Multi_ack_detailed
    ; `Thin_pack
    ; `Side_band_64k
    ; `Ofs_delta
    ; `Agent "git/2.0.0"
    ; `Report_status
    ; `No_done ]
end

module Web_cohttp_lwt = Web_cohttp_lwt
module Cstruct_buffer = Cstruct_buffer

module Make
    (K : Git.Sync.CAPABILITIES)
    (C : Git.Sync_http.CLIENT
     with type +'a io = 'a Lwt.t
      and type headers = Web_cohttp_lwt.HTTP.headers
      and type body = unit -> (Cstruct.t * int * int) option Lwt.t
      and type meth = Web_cohttp_lwt.HTTP.meth
      and type uri = Web_cohttp_lwt.uri
      and type resp = Web_cohttp_lwt.resp)
    (S : Git.Minimal.S
     with type Hash.Digest.buffer = Cstruct.t
      and type Hash.hex = string)
  : Git.Sync_http.S
    with module Web    := Web_cohttp_lwt
     and module Client := C
     and module Store  := S
     and module Buffer := Cstruct_buffer
= struct
  include Git.Sync_http.Make(K)(Web_cohttp_lwt)(C)(S)(Cstruct_buffer)
end


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

open CSig

exception Empty = Stack.Empty

type 'a t = 'a list ref

let create () = ref []
let push x l = l := x :: !l
let pop l = match !l with [] -> raise Stack.Empty | x::xs -> l := xs; x
let top l = match !l with [] -> raise Stack.Empty | x::_ -> x
let find f l = List.find f !l
let find_map f l =
  let rec aux = function
  | [] -> raise Not_found
  | x :: xs -> match f x with None -> aux xs | Some i -> i
  in
  aux !l
let seek f accu l =
  let rec aux accu = function
    | [] -> raise Not_found
    | x :: xs -> match f accu x with Stop x -> x | Next i -> aux accu xs in
  aux accu !l
let is_empty l = match !l with [] -> true | _ -> false
let iter f l = List.iter f !l
let clear l = l := []
let length l = List.length !l
let to_list l = !l

Fix bug in CStack introduced by refactoring

(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

open CSig

exception Empty = Stack.Empty

type 'a t = 'a list ref

let create () = ref []
let push x l = l := x :: !l
let pop l = match !l with [] -> raise Stack.Empty | x::xs -> l := xs; x
let top l = match !l with [] -> raise Stack.Empty | x::_ -> x
let find f l = List.find f !l
let find_map f l =
  let rec aux = function
  | [] -> raise Not_found
  | x :: xs -> match f x with None -> aux xs | Some i -> i
  in
  aux !l
let seek f accu l =
  let rec aux accu = function
    | [] -> raise Not_found
    | x :: xs -> match f accu x with Stop x -> x | Next i -> aux i xs in
  aux accu !l
let is_empty l = match !l with [] -> true | _ -> false
let iter f l = List.iter f !l
let clear l = l := []
let length l = List.length !l
let to_list l = !l


(*
 * Copyright (c) 2014 Citrix Systems Inc
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

include Vchan.S.ENDPOINT

Add another `port` -> `Vchan.Port.t` alias

(*
 * Copyright (c) 2014 Citrix Systems Inc
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

include Vchan.S.ENDPOINT with type port = Vchan.Port.t


let passing =
  QCheck.Test.make ~count:1000
    ~name:"list_rev_is_involutive"
    QCheck.(list small_int)
    (fun l -> List.rev (List.rev l) = l);;

let failing =
  QCheck.Test.make ~count:10
    ~name:"fail_sort_id"
    QCheck.(list small_int)
    (fun l -> l = List.sort compare l);;

let () =
  let open OUnit2 in
  run_test_tt_main
    ("tests" >:::
       List.map QCheck_runner.to_ounit2_test [passing; failing])

Add test case for raising exception

let passing =
  QCheck.Test.make ~count:1000
    ~name:"list_rev_is_involutive"
    QCheck.(list small_int)
    (fun l -> List.rev (List.rev l) = l);;

let failing =
  QCheck.Test.make ~count:10
    ~name:"fail_sort_id"
    QCheck.(list small_int)
    (fun l -> l = List.sort compare l);;

exception Error

let error =
  QCheck.Test.make ~count:10
    ~name:"error_raise_exn"
    QCheck.int
    (fun _ -> raise Error)

let () =
  Printexc.record_backtrace true;
  let open OUnit2 in
  run_test_tt_main
    ("tests" >:::
     List.map QCheck_runner.to_ounit2_test [passing; failing; error])


open OUnit2
open Util

let test_find_xml_child_existent test_ctxt =
    let elem = Xml.Element ("foo", [],
                            [Xml.Element ("bar", [], []);
                             Xml.PCData "baz"])
    in
    match (find_xml_child "bar" elem) with
    | None -> assert_failure "find_xml_child returned None"
    | Some x -> assert_equal (Xml.tag x) "bar"

let test_find_xml_child_nonexistent test_ctxt =
    let elem = Xml.Element ("foo", [], [Xml.Element ("quux", [], [])]) in
    assert_equal (find_xml_child "bar" elem) None

let test_string_of_path test_ctxt =
    let path = ["foo"; "bar"; "baz"] in
    assert_equal (string_of_path path) "[foo bar baz]"

let suite =
    "Util tests" >::: [
        "test_find_xml_child_existent" >:: test_find_xml_child_existent;
        "test_find_xml_child_nonexistent" >:: test_find_xml_child_nonexistent;
        "test_string_of_path" >:: test_string_of_path;
    ]

let () =
  run_test_tt_main suite

Fix the string_of_path test (square brackets are no longer part of the output).

open OUnit2
open Util

let test_find_xml_child_existent test_ctxt =
    let elem = Xml.Element ("foo", [],
                            [Xml.Element ("bar", [], []);
                             Xml.PCData "baz"])
    in
    match (find_xml_child "bar" elem) with
    | None -> assert_failure "find_xml_child returned None"
    | Some x -> assert_equal (Xml.tag x) "bar"

let test_find_xml_child_nonexistent test_ctxt =
    let elem = Xml.Element ("foo", [], [Xml.Element ("quux", [], [])]) in
    assert_equal (find_xml_child "bar" elem) None

let test_string_of_path test_ctxt =
    let path = ["foo"; "bar"; "baz"] in
    assert_equal (String.trim (string_of_path path)) "foo bar baz"

let suite =
    "Util tests" >::: [
        "test_find_xml_child_existent" >:: test_find_xml_child_existent;
        "test_find_xml_child_nonexistent" >:: test_find_xml_child_nonexistent;
        "test_string_of_path" >:: test_string_of_path;
    ]

let () =
  run_test_tt_main suite


(* Try to read the HOME environment
 * if it is not set we assume it's windows and fallback to USERPROFILE *)
let home = match Sys.getenv_opt "HOME" with
| Some(p) -> p
| None -> Sys.getenv "USERPROFILE"
in

let () = Unix.openfile (home ^ "/.utoprc") [] 0o640
|> Unix.close in

let () = Unix.openfile (home ^ "/.utop-history") [] 0o640
|> Unix.close in

(* Get the dir of the current executable *)
let dir = Filename.dirname Sys.argv.(0) in

(* If there is only 1 arg it's the exeuctable and we can remove that *)
let argv = match Array.length Sys.argv with
| 1 -> [||]
| argLength -> Array.sub Sys.argv 1 argLength
in

let args = if Array.length argv == 1 && argv.(0) = "stdin" then
  let refmted = Pervasives.input_line (Unix.open_process_in "refmt --parse re --print ml --interface false") in

  Array.concat [[|"utop-full";|]; argv; [|refmted|]]
else
  Array.concat [[|"utop-full"; "-init"; dir ^ "/rtop_init.ml";|]; argv; [|"-I"; home; "-safe-string"|]]
in

Unix.execvp "utop-full" args

Implement getenv_opt for ocaml <= 4.04

let getenv_opt env =
  try Some(Sys.getenv env)
  with Not_found -> None
in

(* Try to read the HOME environment
 * if it is not set we assume it's windows and fallback to USERPROFILE *)
let home = match getenv_opt "HOME" with
| Some(p) -> p
| None -> Sys.getenv "USERPROFILE"
in

let () = Unix.openfile (home ^ "/.utoprc") [] 0o640
|> Unix.close in

let () = Unix.openfile (home ^ "/.utop-history") [] 0o640
|> Unix.close in

(* Get the dir of the current executable *)
let dir = Filename.dirname Sys.argv.(0) in

(* If there is only 1 arg it's the exeuctable and we can remove that *)
let argv = match Array.length Sys.argv with
| 1 -> [||]
| argLength -> Array.sub Sys.argv 1 argLength
in

let args = if Array.length argv == 1 && argv.(0) = "stdin" then
  let refmted = Pervasives.input_line (Unix.open_process_in "refmt --parse re --print ml --interface false") in

  Array.concat [[|"utop-full";|]; argv; [|refmted|]]
else
  Array.concat [[|"utop-full"; "-init"; dir ^ "/rtop_init.ml";|]; argv; [|"-I"; home; "-safe-string"|]]
in

Unix.execvp "utop-full" args


open Protocol

let port = ref 8080
let name = ref "default_name"
let payload = ref "hello"
let reply = ref false

let main () =
	lwt c = Connection.make !port in

let _ =
	Arg.parse [
		"-port", Arg.Set_int port, (Printf.sprintf "port broker listens on (default %d)" !port);
		"-name", Arg.Set_string name, (Printf.sprintf "name to send message to (default %s)" !name);
		"-payload", Arg.Set_string payload, (Printf.sprintf "payload of message to send (default %s)" !payload);
		"-reply", Arg.Set reply, (Printf.sprintf "wait for a reply (default %b)" !reply);
	] (fun x -> Printf.fprintf stderr "Ignoring unexpected argument: %s" x)
		"Send a message to a name, optionally waiting for a response";

	Lwt_unix.run (make_server ())

Add the ability to send a frame to the switch

open Cohttp_lwt_unix
open Lwt
open Protocol

let port = ref 8080
let name = ref "default_name"
let payload = ref "hello"
let reply = ref false

let main () =
	lwt ic, oc = Connection.make !port in
	let frame = Frame.Send(!name, !payload) in
	let http_request = Frame.to_request frame in
	lwt () = Request.write (fun _ _ -> return ()) http_request oc in
	match_lwt Response.read ic with
	| Some http_response ->
		if Response.status http_response <> `OK then begin
			Printf.fprintf stderr "Failed to read response\n%!";
			lwt () = Response.write (fun _ _ -> return ()) http_response Lwt_io.stderr in
			return ()
		end else begin
			Printf.fprintf stderr "OK\n%!";
			return ()
		end
	| None ->
		Printf.fprintf stderr "Failed to read response\n%!";
		return ()

let _ =
	Arg.parse [
		"-port", Arg.Set_int port, (Printf.sprintf "port broker listens on (default %d)" !port);
		"-name", Arg.Set_string name, (Printf.sprintf "name to send message to (default %s)" !name);
		"-payload", Arg.Set_string payload, (Printf.sprintf "payload of message to send (default %s)" !payload);
		"-reply", Arg.Set reply, (Printf.sprintf "wait for a reply (default %b)" !reply);
	] (fun x -> Printf.fprintf stderr "Ignoring unexpected argument: %s" x)
		"Send a message to a name, optionally waiting for a response";

	Lwt_unix.run (main ())


(* 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. *)

let temp_name =
  let rng = Random.State.make_self_init () in
  fun () ->
    let number = Random.State.int rng 10000 in
    Printf.sprintf (*"_build/"*)"lwt-testing-%04d" number

let temp_file () =
  Filename.temp_file (*~temp_dir:"_build"*) "lwt-testing-" ""

let temp_directory () =
  let rec attempt () =
    let path = temp_name () in
    try
      Unix.mkdir path 0o755;
      path
    with Unix.Unix_error (Unix.EEXIST, "mkdir", _) -> attempt ()
  in
  attempt ()

Reduce pollution of /tmp by the test suite

(* 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. *)

let temp_name =
  let rng = Random.State.make_self_init () in
  fun () ->
    let number = Random.State.int rng 10000 in
    Printf.sprintf "lwt-testing-%04d" number

let temp_file () =
  Filename.temp_file ~temp_dir:"." "lwt-testing-" ""

let temp_directory () =
  let rec attempt () =
    let path = temp_name () in
    try
      Unix.mkdir path 0o755;
      path
    with Unix.Unix_error (Unix.EEXIST, "mkdir", _) -> attempt ()
  in
  attempt ()


(** Cilfacade functions to avoid dependency cycles.*)
open Cil

let get_labelLoc = function
  | Label (_, loc, _) -> loc
  | Case (_, loc, _) -> loc
  | CaseRange (_, _, loc, _) -> loc
  | Default (loc, _) -> loc

let rec get_labelsLoc = function
  | [] -> Cil.locUnknown
  | label :: labels ->
    let loc = get_labelLoc label in
    if CilType.Location.equal loc Cil.locUnknown then
      get_labelsLoc labels (* maybe another label has known location *)
    else
      loc

let get_stmtkindLoc = Cil.get_stmtLoc (* CIL has a confusing name for this function *)

let get_stmtLoc stmt =
  match stmt.skind with
  (* Cil.get_stmtLoc returns Cil.locUnknown in these cases, so try labels instead *)
  | Instr []
  | Block {bstmts = []; _} ->
    get_labelsLoc stmt.labels
  | If(_, _, _, _, eloc) -> eloc
  | Loop (_, _, eloc, _, _) -> eloc
  | _ -> get_stmtkindLoc stmt.skind

Revert "Return location of if stmts to only be the head!" This was not supposed to go here. Stupid git!

(** Cilfacade functions to avoid dependency cycles.*)
open Cil

let get_labelLoc = function
  | Label (_, loc, _) -> loc
  | Case (_, loc, _) -> loc
  | CaseRange (_, _, loc, _) -> loc
  | Default (loc, _) -> loc

let rec get_labelsLoc = function
  | [] -> Cil.locUnknown
  | label :: labels ->
    let loc = get_labelLoc label in
    if CilType.Location.equal loc Cil.locUnknown then
      get_labelsLoc labels (* maybe another label has known location *)
    else
      loc

let get_stmtkindLoc = Cil.get_stmtLoc (* CIL has a confusing name for this function *)

let get_stmtLoc stmt =
  match stmt.skind with
  (* Cil.get_stmtLoc returns Cil.locUnknown in these cases, so try labels instead *)
  | Instr []
  | Block {bstmts = []; _} ->
    get_labelsLoc stmt.labels
  | _ -> get_stmtkindLoc stmt.skind


open Core.Std

(* let times_to_repeat = 40 *)
let times_to_repeat = 50

let () =
  let require_line = (function
      | None -> failwith "input required"
      | Some line -> line) in
  In_channel.input_line stdin
  |> require_line
  |> MathSequence.iterate ~f:LookAndSay.next ~count:times_to_repeat
  |> String.length |> Int.to_string
  |> print_string

Rearrange lines in day 10 to be easier to read


val main : ?page:int ->
  [< Html5_types.div_content_fun > `A `Br `Div `Footer `Header `P ]
  Html.elt list -> [> `Html ] Html.elt Lwt.t
val user : ?page:int ->
  [< Html5_types.div_content_fun > `A `Br `Div `Footer `Header `P ]
  Html.elt list -> string -> [> `Html ] Html.elt Lwt.t
val tag : ?page:int ->
  [< Html5_types.div_content_fun > `A `Br `Div `Footer `Header `P ]
  Html.elt list -> string -> [> `Html ] Html.elt Lwt.t
val register : unit -> [> `Html ] Html.elt Lwt.t
val view_feed : int -> [> `Html ] Html.elt Lwt.t
val preferences :
  [< Html5_types.div_content_fun > `Form `Header `PCDATA ] Html.elt list ->
  [> `Html ] Html.elt Lwt.t

Fix the interface of Templates

val main :
  ?page:int ->
  service:'a ->
  unit ->
  [> `Html ] Html.elt Lwt.t
val user :
  ?page:int ->
  service:'a ->
  string ->
  [> `Html ] Html.elt Lwt.t
val tag :
  ?page:int ->
  service:'a ->
  string ->
  [> `Html ] Html.elt Lwt.t
val register : unit -> [> `Html ] Html.elt Lwt.t
val view_feed : int -> [> `Html ] Html.elt Lwt.t
val preferences : unit -> [> `Html ] Html.elt Lwt.t


open Mirage

type shellconfig = ShellConfig
let shellconfig = Type ShellConfig

let config_shell =
  let build _ =
    Bos.OS.Cmd.run Bos.Cmd.(v "dd" % "if=/dev/zero" % "of=disk.img" % "count=100000")
  in
  let clean _ = Bos.OS.File.delete (Fpath.v "disk.img") in
  impl ~build ~clean "Functoria_runtime" shellconfig

let main =
  let packages = [ package "io-page"; package "duration"; package ~build:true "bos"; package ~build:true "fpath" ] in
  foreign
    ~packages
    ~deps:[abstract config_shell] "Unikernel.Main" (time @-> block @-> job)

let img = Key.(if_impl is_solo5 (block_of_file "storage") (block_of_file "disk.img"))

let () =
  register "block_test" [main $ default_time $ img]

Update to not use the Type constructor directly

open Mirage

type shellconfig = ShellConfig
let shellconfig = Type.v ShellConfig

let config_shell =
  let build _ =
    Bos.OS.Cmd.run Bos.Cmd.(v "dd" % "if=/dev/zero" % "of=disk.img" % "count=100000")
  in
  let clean _ = Bos.OS.File.delete (Fpath.v "disk.img") in
  impl ~build ~clean "Functoria_runtime" shellconfig

let main =
  let packages = [ package "io-page"; package "duration"; package ~build:true "bos"; package ~build:true "fpath" ] in
  foreign
    ~packages
    ~deps:[abstract config_shell] "Unikernel.Main" (time @-> block @-> job)

let img = Key.(if_impl is_solo5 (block_of_file "storage") (block_of_file "disk.img"))

let () =
  register "block_test" [main $ default_time $ img]


module Error : module type of Syndic_error

type error
type warning

type 'a kind
(** Distinguishes an error from a warning. *)

val error : error kind
val warning : warning kind

type 'a t =
  {
    kind    : 'a kind; (** Error or warning. *)
    line    : int;    (** Within the source code of the validated document,
                          refers to the line where the error was
                          detected. *)
    column  : int;    (** Within the source code of the validated document,
                          refers to the line where the column was
                          detected. *)
    text    : string; (** The actual error message. *)
    element : string; (** Element in the feed where the message was
                          triggered. *)
    parent  : string; (** In the feed, parent of the element. *)
    value   : string; (** If applicable the value of the element, attribute
                          or content which triggered the message. *)
  }

val url : [< `Data of string | `Uri of Uri.t ] -> Uri.t
(** Generate url for the W3C Feed Validator API returning a SOAP 12
    output.  Thus URL is supposed to be used with GET. *)

val to_error : _ t -> Error.t

val parse : Xmlm.input -> error t list * warning t list
(** [parse i] takes [i] and returns a list of error, result of
    {{:http://validator.w3.org/feed/docs/soap} W3C Feed Validator}. *)

Add a description of the module Syndic.W3C

(** [Syndic.W3C]: invoke and parse the result of the W3C validator.  *)

module Error : module type of Syndic_error

type error
type warning

type 'a kind
(** Distinguishes an error from a warning. *)

val error : error kind
val warning : warning kind

type 'a t =
  {
    kind    : 'a kind; (** Error or warning. *)
    line    : int;    (** Within the source code of the validated document,
                          refers to the line where the error was
                          detected. *)
    column  : int;    (** Within the source code of the validated document,
                          refers to the line where the column was
                          detected. *)
    text    : string; (** The actual error message. *)
    element : string; (** Element in the feed where the message was
                          triggered. *)
    parent  : string; (** In the feed, parent of the element. *)
    value   : string; (** If applicable the value of the element, attribute
                          or content which triggered the message. *)
  }

val url : [< `Data of string | `Uri of Uri.t ] -> Uri.t
(** Generate url for the W3C Feed Validator API returning a SOAP 12
    output.  Thus URL is supposed to be used with GET. *)

val to_error : _ t -> Error.t

val parse : Xmlm.input -> error t list * warning t list
(** [parse i] takes [i] and returns a list of error, result of
    {{:http://validator.w3.org/feed/docs/soap} W3C Feed Validator}. *)


open Client_cfg
open OUnit

let test_parsing () =
  let lines = [
    "[global]";
   "cluster_id = sturdy";
   "cluster = sturdy_0,sturdy_1, sturdy_2  ";
   "\n";
   "[sturdy_0]";
   "client_port = 7080";
   "name = sturdy_0";
   "ip = 127.0.0.1";
   "\n";
   "[sturdy_1]";
   "client_port = 7081";
   "name = sturdy_1";
   "ip = 127.0.0.1";
   "\n";
   "[sturdy_2]";
   "ip = 127.0.0.1";
   "client_port = 7082";
   "name = sturdy_2"]
  in
  let contents = List.fold_left (fun acc v -> acc ^ "\n" ^ v) "" lines in
  let fn = "/tmp/client_cfg_test.ml" in
  let oc = open_out "/tmp/client_cfg_test.ml" in
  let () = output_string oc contents in
  let () = close_out oc in
  let cfg = ClientCfg.from_file fn "global" in
  let sa0 = ClientCfg.get cfg "sturdy_0" in
  OUnit.assert_equal sa0 ("127.0.0.1",7080)

let suite = "client_cfg" >:::[
  "parsing" >:: test_parsing;
]

Fix for cfg parsing unit tests

open Client_cfg
open OUnit

let test_parsing () =
  let lines = [
    "[global]";
   "cluster_id = sturdy";
   "cluster = sturdy_0,sturdy_1, sturdy_2  ";
   "\n";
   "[sturdy_0]";
   "client_port = 7080";
   "name = sturdy_0";
   "ip = 127.0.0.1";
   "\n";
   "[sturdy_1]";
   "client_port = 7081";
   "name = sturdy_1";
   "ip = 127.0.0.1";
   "\n";
   "[sturdy_2]";
   "ip = 127.0.0.1";
   "client_port = 7082";
   "name = sturdy_2"]
  in
  let contents = List.fold_left (fun acc v -> acc ^ "\n" ^ v) "" lines in
  let fn = "/tmp/client_cfg_test.ml" in
  let oc = open_out "/tmp/client_cfg_test.ml" in
  let () = output_string oc contents in
  let () = close_out oc in
  let cfg = ClientCfg.from_file "global" fn in
  let sa0 = ClientCfg.get cfg "sturdy_0" in
  OUnit.assert_equal sa0 ("127.0.0.1",7080)

let suite = "client_cfg" >:::[
  "parsing" >:: test_parsing;
]


open Wrapper
module CArray = Ctypes.CArray

let ok_exn (result : 'a Session.result) ~context =
  match result with
  | Ok result -> result
  | Error status ->
    Printf.sprintf "Error in %s: %s" context (Status.message status)
    |> failwith

let () =
  let node =
    Ops.add
      (Ops_m.const_float_1d ~type_:Float [ 2.; 1.; 1. ])
      (Ops_m.const_float_1d ~type_:Float [ -1.; 3.; 0. ])
    |> Ops.exp
  in
  let session_options = Session_options.create () in
  let session =
    Session.create session_options
    |> ok_exn ~context:"session creation"
  in
  Session.extend_graph
    session
    (Protobuf.of_node node)
    |> ok_exn ~context:"extending graph";
  let output =
    Session.run
      session
      ~inputs:[]
      ~outputs:[ node.name |> Node.Name.to_string ]
      ~targets:[ node.name |> Node.Name.to_string ]
    |> ok_exn ~context:"session run"
  in
  match output with
  | [ output_tensor ] ->
    let data = Tensor.data output_tensor Ctypes.float 2 in
    Printf.printf "%f %f\n%!" (CArray.get data 0) (CArray.get data 1)
  | [] | _ :: _ :: _ -> assert false

Print the full tensor in the example.

open Wrapper
module CArray = Ctypes.CArray

let ok_exn (result : 'a Session.result) ~context =
  match result with
  | Ok result -> result
  | Error status ->
    Printf.sprintf "Error in %s: %s" context (Status.message status)
    |> failwith

let () =
  let node =
    Ops.add
      (Ops_m.const_float_1d ~type_:Float [ 2.; 1.; 1. ])
      (Ops_m.const_float_1d ~type_:Float [ -1.; 3.; 0. ])
    |> Ops.exp
  in
  let session_options = Session_options.create () in
  let session =
    Session.create session_options
    |> ok_exn ~context:"session creation"
  in
  Session.extend_graph
    session
    (Protobuf.of_node node)
    |> ok_exn ~context:"extending graph";
  let output =
    Session.run
      session
      ~inputs:[]
      ~outputs:[ node.name |> Node.Name.to_string ]
      ~targets:[ node.name |> Node.Name.to_string ]
    |> ok_exn ~context:"session run"
  in
  match output with
  | [ output_tensor ] ->
    let dim = Tensor.dim output_tensor 0 in
    let data = Tensor.data output_tensor Ctypes.float dim in
    for d = 0 to dim - 1 do
      Printf.printf "%d %f\n%!" d (CArray.get data d)
    done
  | [] | _ :: _ :: _ -> assert false


open Asttypes
open Parsetree

#if OCAML_VERSION >= (4, 03, 0) (* OCaml 4.03.0 or above *)

let nolabel = Nolabel (* Asttypes.arg_label for 4.03 only *)

module Const =
struct
  let int ?suffix n = PConst_int (string_of_int n, suffix)
  let string ?quot s = PConst_string (s, quot)
end

#else (* OCaml 4.00.0 .. 4.02.3 *)

let nolabel = ""

module Const =
struct
  let int ?suffix n = Const_int n
  let string ?quot s = Const_string (s, quot)
end

#endif

Fix a syntax error in CPPO


(*
 * Copyright (C) Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
 * GNU Lesser General Public License for more details.
 *)

type t = {
	name : string;
	description : string;
	enabled : bool;
	standard : bool;
	min : float;
	max : float;
	units : string
}

let to_key_value_map ds = [
	"name_label", ds.name;
	"name_description", ds.description;
	"enabled", string_of_bool ds.enabled;
	"standard", string_of_bool ds.standard;
	"min", string_of_float ds.min;
	"max", string_of_float ds.max;
	"units", ds.units;
]

let to_API_data_source (ds : t) = {
	API.data_source_name_label = ds.name;
	data_source_name_description = ds.description;
	data_source_enabled = ds.enabled;
	data_source_standard = ds.standard;
	data_source_units = ds.units;
	data_source_min = ds.min;
	data_source_max = ds.max;
	data_source_value = 0.;
}

Remove rrdd code dependent on xen-api


(*
 * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
 *)

module M (IO:IO.M) = struct

  module Parser = Parser.M(IO)
  module Transfer = Transfer.M(IO)
  open IO

  type response = {
    ic: ic;
    encoding: Transfer.encoding;
    headers: (string * string) list;
    version: Code.version;
    status: Code.status_code;
  }

  let parse ic =
    Parser.parse_response_fst_line ic >>= function
    |None -> return None
    |Some (version, status) ->
       Parser.parse_headers ic >>= fun headers ->
       let encoding = Transfer.parse_transfer_encoding headers in
       return (Some { ic; encoding; headers; version; status })

  let version r = r.version
  let status r = r.status
  let body r = Transfer.read r.encoding r.ic
end

Switch to use the Header API

(*
 * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *
 *)

module M (IO:IO.M) = struct

  module Parser = Parser.M(IO)
  module Transfer = Transfer.M(IO)
  open IO

  type response = {
    ic: ic;
    encoding: Transfer.encoding;
    headers: Header.t;
    version: Code.version;
    status: Code.status_code;
  }

  let parse ic =
    Parser.parse_response_fst_line ic >>= function
    |None -> return None
    |Some (version, status) ->
       Parser.parse_headers ic >>= fun headers ->
       let encoding = Transfer.parse_transfer_encoding headers in
       return (Some { ic; encoding; headers; version; status })

  let version r = r.version
  let status r = r.status
  let body r = Transfer.read r.encoding r.ic
end