module B = Decompress_b
module Adler32 = Decompress_adler32

type read  = [ `Read ]
type write = [ `Write ]

type ('a, 'i) t = 'i B.t constraint 'a = [< `Read | `Write ]

let read_and_write : 'i B.t -> ([ read | write ], 'i) t = fun x -> x
let read_only      : 'i B.t -> (read, 'i) t             = fun x -> x
let write_only     : 'i B.t -> (write, 'i) t            = fun x -> x

let length    = B.length
let get       = B.get
let set       = B.set
let get_u16   = B.get_u16
let get_u32   = B.get_u32
let get_u64   = B.get_u64
let sub       = B.sub
let fill      = B.fill
let blit      = B.blit
let pp        = B.pp
let to_string = B.to_string
let adler32   = Adler32.adler32

external proof : ('a, 'i) t -> 'i B.t = "%identity"

Change API of Safe (it's an internal thing)

module B = Decompress_b
module Adler32 = Decompress_adler32

type read  = [ `Read ]
type write = [ `Write ]

type ('a, 'i) t = 'i B.t constraint 'a = [< `Read | `Write ]

let read_and_write : 'i B.t -> ([ read | write ], 'i) t = fun x -> x
let read_only      : 'i B.t -> (read, 'i) t             = fun x -> x
let write_only     : 'i B.t -> (write, 'i) t            = fun x -> x

let length    = B.length
let get       = B.get
let set       = B.set
let get_u16   = B.get_u16
let get_u32   = B.get_u32
let get_u64   = B.get_u64
let sub       = B.sub
let fill      = B.fill
let blit      = B.blit
let pp        = B.pp
let to_string = B.to_string
let adler32   = Adler32.adler32

external from : ('a, 'i) t -> 'i B.t = "%identity"


module Calendar = CalendarLib.Calendar

let string_of_calendar cal =
  (string_of_int (Calendar.day_of_month cal)) ^ "/" ^
    (string_of_int (Calendar.Date.int_of_month (Calendar.month cal))) ^ "/" ^
    (string_of_int (Calendar.year cal)) ^ " à " ^
    (string_of_int (Calendar.hour cal)) ^ ":" ^
    (string_of_int (Calendar.minute cal)) ^ ":" ^
    (string_of_int (Calendar.second cal))

let string_is_empty str =
  let length = String.length str in
  let rec inner i =
    if i < length then
      (str.[i] = ' ') && inner (i + 1)
    else
      true in
  inner 0

let msg str = [
  Html.p [
    Html.pcdata str
  ]
]

let is_invalid_url input =
  let regexp_match_url =
    let legit_chars = "[]0-9A-Za-z_~ ().,+=&-]" in
    "^\\(https?\\|ftp\\)://" ^           (* Protocol *)
      "[A-Za-z0-9.]+" ^                  (* domaine name *)
      "\\(/"   ^ legit_chars ^ "*\\)*" ^ (* Arborescence *)
      "\\(\\?" ^ legit_chars ^ "*\\)?" ^ (* Parameters *)
      "\\(#"   ^ legit_chars ^ "*\\)$"   (* Anchor *) in
  not (Str.string_match (Str.regexp regexp_match_url) input 0)

Fix Utils.is_invalid_url: the urls requires an anchor

module Calendar = CalendarLib.Calendar

let string_of_calendar cal =
  (string_of_int (Calendar.day_of_month cal)) ^ "/" ^
    (string_of_int (Calendar.Date.int_of_month (Calendar.month cal))) ^ "/" ^
    (string_of_int (Calendar.year cal)) ^ " à " ^
    (string_of_int (Calendar.hour cal)) ^ ":" ^
    (string_of_int (Calendar.minute cal)) ^ ":" ^
    (string_of_int (Calendar.second cal))

let string_is_empty str =
  let length = String.length str in
  let rec inner i =
    if i < length then
      (str.[i] = ' ') && inner (i + 1)
    else
      true in
  inner 0

let msg str = [
  Html.p [
    Html.pcdata str
  ]
]

let is_invalid_url input =
  let regexp_match_url =
    let legit_chars = "[]0-9A-Za-z_~ ().,+=&-]" in
    "^\\(https?\\|ftp\\)://" ^           (* Protocol *)
      "[A-Za-z0-9.]+" ^                  (* domaine name *)
      "\\(/"   ^ legit_chars ^ "*\\)*" ^ (* Arborescence *)
      "\\(\\?" ^ legit_chars ^ "*\\)?" ^ (* Parameters *)
      "\\(#"   ^ legit_chars ^ "*\\)?$"   (* Anchor *) in
  not (Str.string_match (Str.regexp regexp_match_url) input 0)


open OUnit2

let test_encode_decode =
  "test encode decode" >:::
  List.map (fun t ->
      let open P11_mechanism_type in
      let test expected ctxt =
        let encode_decode = P11_mechanism_type.of_string
            (P11_mechanism_type.to_string expected) in
        assert_equal
          ~ctxt
          ~cmp:P11_mechanism_type.equal
          ~printer:P11_mechanism_type.show
          expected
          encode_decode
      in
      (Printf.sprintf "[%s]") (P11_mechanism_type.to_string t) >:: test
        t
    ) P11_mechanism_type.elements

let suite =
  "P11_mechanism" >:::
  [ test_encode_decode
  ]

Refactor the new test for readability

open OUnit2

let test_encode_decode =
  "test encode decode" >:::
  let test expected ctxt =
    let encode_decode = P11_mechanism_type.of_string (P11_mechanism_type.to_string expected) in
    assert_equal
      ~ctxt
      ~cmp:P11_mechanism_type.equal
      ~printer:P11_mechanism_type.show
      expected
      encode_decode
  in
  List.map
    (fun t -> (Printf.sprintf "[%s]") (P11_mechanism_type.to_string t) >:: test t)
    P11_mechanism_type.elements

let suite =
  "P11_mechanism" >:::
  [ test_encode_decode
  ]


module Html = Dom_html

let start test _ =
  let open Js.Unsafe in
  let webtest = Js.Unsafe.obj [||] in
  webtest##.finished := Js._false;
  webtest##.passed := Js._false;
  webtest##.run := Js.wrap_callback
    (fun () ->
      Webtest.Utils.run test (fun {Webtest.Utils.log; results} ->
        let total, errored, failed, succeeded =
          List.fold_left
            (fun (total, errors, failures, successes) result ->
              let open Webtest.Suite in
              match result with
              | Error _ -> total + 1, errors + 1, failures, successes
              | Failure _ -> total + 1, errors, failures + 1, successes
              | Success -> total + 1, errors, failures, successes + 1)
            (0, 0, 0, 0) results
        in
        let final_log =
          String.concat "\n" [
            log;
            Printf.sprintf "%d tests run" total;
            Printf.sprintf "%d errors" errored;
            Printf.sprintf "%d failures" failed;
            Printf.sprintf "%d succeeded" succeeded;
          ]
        in
        let passed = total = succeeded in
        webtest##.log := Js.string final_log;
        webtest##.passed := if passed then Js._true else Js._false;
        webtest##.finished := Js._true));

  global##.webtest := webtest;

  Js._false

let setup test =
  Html.window##.onload := Html.handler (start test)

Rename some values in Webtest_runner

module Html = Dom_html

let run suite _ =
  let open Js.Unsafe in
  let webtest = Js.Unsafe.obj [||] in
  webtest##.finished := Js._false;
  webtest##.passed := Js._false;
  webtest##.run := Js.wrap_callback
    (fun () ->
      Webtest.Utils.run suite (fun {Webtest.Utils.log; results} ->
        let total, errored, failed, succeeded =
          List.fold_left
            (fun (total, errors, failures, successes) result ->
              let open Webtest.Suite in
              match result with
              | Error _ -> total + 1, errors + 1, failures, successes
              | Failure _ -> total + 1, errors, failures + 1, successes
              | Success -> total + 1, errors, failures, successes + 1)
            (0, 0, 0, 0) results
        in
        let final_log =
          String.concat "\n" [
            log;
            Printf.sprintf "%d tests run" total;
            Printf.sprintf "%d errors" errored;
            Printf.sprintf "%d failures" failed;
            Printf.sprintf "%d succeeded" succeeded;
          ]
        in
        let passed = total = succeeded in
        webtest##.log := Js.string final_log;
        webtest##.passed := if passed then Js._true else Js._false;
        webtest##.finished := Js._true));

  global##.webtest := webtest;

  Js._false

let setup suite =
  Html.window##.onload := Html.handler (run suite)


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

include V1_LWT.BLOCK
  with type id = string

Add explicit 'connect' to interface

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

include V1_LWT.BLOCK
  with type id = string

val connect : string -> [`Ok of t | `Error of error] io


type cfgInfo = {
    name: string; (* The function name *)
    start   : int;
    size    : int;
    blocks: cfgBlock array; (** Dominating blocks must come first *)
    successors: int list array; (* block indices *)
    predecessors: int list array;
    mutable nrRegs: int;
    mutable regToVarinfo: Cil.varinfo array; (** Map register IDs to varinfo *)
  }

(** A block corresponds to a statement *)
and cfgBlock = {
    bstmt: Cil.stmt;

    (* We abstract the statement as a list of def/use instructions *)
    instrlist: instruction list;
    mutable livevars: (reg * int) list;
    (** For each variable ID that is live at the start of the block, the
     * block whose definition reaches this point. If that block is the same
     * as the current one, then the variable is a phi variable *)
    mutable reachable: bool;
  }

and instruction = (reg list * reg list)
  (* lhs variables, variables on rhs.  *)

and reg = int

type idomInfo = int array  (* immediate dominator *)

and dfInfo = (int list) array  (* dominance frontier *)

and oneSccInfo = {
    nodes: int list;
    headers: int list;
    backEdges: (int*int) list;
  }

and sccInfo = oneSccInfo list

val add_ssa_info: cfgInfo -> unit
val stronglyConnectedComponents: cfgInfo -> bool -> sccInfo
val prune_cfg: cfgInfo -> cfgInfo

Add in compute_idom, which we depend on

type cfgInfo = {
    name: string; (* The function name *)
    start   : int;
    size    : int;
    blocks: cfgBlock array; (** Dominating blocks must come first *)
    successors: int list array; (* block indices *)
    predecessors: int list array;
    mutable nrRegs: int;
    mutable regToVarinfo: Cil.varinfo array; (** Map register IDs to varinfo *)
  }

(** A block corresponds to a statement *)
and cfgBlock = {
    bstmt: Cil.stmt;

    (* We abstract the statement as a list of def/use instructions *)
    instrlist: instruction list;
    mutable livevars: (reg * int) list;
    (** For each variable ID that is live at the start of the block, the
     * block whose definition reaches this point. If that block is the same
     * as the current one, then the variable is a phi variable *)
    mutable reachable: bool;
  }

and instruction = (reg list * reg list)
  (* lhs variables, variables on rhs.  *)

and reg = int

type idomInfo = int array  (* immediate dominator *)

and dfInfo = (int list) array  (* dominance frontier *)

and oneSccInfo = {
    nodes: int list;
    headers: int list;
    backEdges: (int*int) list;
  }

and sccInfo = oneSccInfo list
val compute_idom: cfgInfo -> idomInfo
val add_ssa_info: cfgInfo -> unit
val stronglyConnectedComponents: cfgInfo -> bool -> sccInfo
val prune_cfg: cfgInfo -> cfgInfo


(* Copyright Vincent Balat *)
(* This file was generated by Eliom-base-app.
   Feel free to use it, modify it, and redistribute it as you wish. *)

(* Here is an example of tip. Call this function while generating the
   widget concerned by the explanation it contains. *)
let example_tip () =
  Os_tips.bubble ()
    ~top:40 ~right:0 ~width:300 ~height:120
    ~arrow:(`top 300)
    ~name:"example"
    ~content:(fun _ -> Eliom_content.Html.F.[
      p [pcdata "This is an example of tip."];
      p [pcdata
           "Look at module %%%MODULE_NAME%%%_tips to see how it is defined."]
    ])

Fix template after os_tips change

(* Copyright Vincent Balat *)
(* This file was generated by Eliom-base-app.
   Feel free to use it, modify it, and redistribute it as you wish. *)

(* Here is an example of tip. Call this function while generating the
   widget concerned by the explanation it contains. *)
let example_tip () =
  Os_tips.bubble ()
    ~top:40 ~right:0 ~width:300 ~height:120
    ~arrow:(`top 300)
    ~name:"example"
    ~content:(fun _ ->
      Lwt.return
        Eliom_content.Html.F.[
          p [pcdata "This is an example of tip."];
          p [pcdata
               "Look at module %%%MODULE_NAME%%%_tips to see how it is defined."]
        ])


type t = string

let of_string x = x
let to_string x = x

let read_file filename =
  let input_channel = open_in filename in
  let size = in_channel_length input_channel in
  let content = Bytes.create size in
  really_input input_channel content 0 size;
  close_in input_channel;
  content

Support -safe-string, the default in OCaml 4.06.0

type t = string

let of_string x = x
let to_string x = x

let read_file filename =
  let input_channel = open_in filename in
  let size = in_channel_length input_channel in
  let content = Bytes.create size in
  really_input input_channel content 0 size;
  close_in input_channel;
  Bytes.to_string content


let rec p1_loop () =
  match Erl.receive () with
    | `Sock_data (sock, data) ->
      Erl_inet.send sock data;
      p1_loop ()
    | `Sock_accept sock ->
      Printf.printf "accepted on %d\n%!" sock;
      p1_loop ()
    | `Sock_error (sock, errno) ->
      Printf.printf
	"got error: %s (%d)\n%!"
	(Erl_inet.strerror errno) errno;
      exit 0
    | _ ->
      p1_loop ()

let p1 () =
  match Erl_inet.listen (Erl.self()) "0.0.0.0" 5222 5 with
    | exception (Erl_inet.Sock_error errno) ->
      Printf.printf "failed to listen: %s\n%!" (Erl_inet.strerror errno)
    | _ ->
      p1_loop ()

let _ =
  let _ = Erl.spawn p1 in
  Erl.run ()

Remove exit left after debug

let rec p1_loop () =
  match Erl.receive () with
    | `Sock_data (sock, data) ->
      Erl_inet.send sock data;
      p1_loop ()
    | `Sock_accept sock ->
      Printf.printf "accepted on %d\n%!" sock;
      p1_loop ()
    | `Sock_error (sock, errno) ->
      Printf.printf
	"got error: %s (%d)\n%!"
	(Erl_inet.strerror errno) errno;
      p1_loop ()
    | _ ->
      p1_loop ()

let p1 () =
  match Erl_inet.listen (Erl.self()) "0.0.0.0" 5222 5 with
    | exception (Erl_inet.Sock_error errno) ->
      Printf.printf "failed to listen: %s\n%!" (Erl_inet.strerror errno)
    | _ ->
      p1_loop ()

let _ =
  let _ = Erl.spawn p1 in
  Erl.run ()


open Ident
open Term
open Decl
open Theory
open Task

let rec curry t = match t.t_node with
  | Tbinop (Timplies, lhs, rhs) -> expand t lhs (curry rhs)
  | _ -> t_map curry t

and expand orig l r = match l.t_node with
  | Tbinop (Tand, a, b) -> expand orig a (expand orig b r)
  | _  -> t_label_copy orig (t_implies (curry l) r)

let curry = Trans.goal (fun pr t -> [create_prop_decl Pgoal pr (curry t)])

let () =
  Trans.register_transform "curry" curry
    ~desc:"Currify."

Fix warning from OCaml compiler

open Term
open Decl

let rec curry t = match t.t_node with
  | Tbinop (Timplies, lhs, rhs) -> expand t lhs (curry rhs)
  | _ -> t_map curry t

and expand orig l r = match l.t_node with
  | Tbinop (Tand, a, b) -> expand orig a (expand orig b r)
  | _  -> t_label_copy orig (t_implies (curry l) r)

let curry = Trans.goal (fun pr t -> [create_prop_decl Pgoal pr (curry t)])

let () =
  Trans.register_transform "curry" curry
    ~desc:"Currify."


(*
 * Copyright (C) 2006-2013 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 D = Debug.Make(struct let name="xapi" end)
open D

let systemctl = "/usr/bin/systemctl"
let gpumon = "xcp-rrdd-gpumon"
let pidfile = "/var/run/xcp-rrdd-gpumon.pid"

module Gpumon = Daemon_manager.Make(struct
	let check = Daemon_manager.Pidfile pidfile

	let start () =
		debug "Starting %s" gpumon;
		ignore (Forkhelpers.execute_command_get_output systemctl ["start"; gpumon])

	let stop () =
		debug "Stopping %s" gpumon;
		ignore (Forkhelpers.execute_command_get_output systemctl ["stop"; gpumon])
end)

let with_gpumon_stopped = Gpumon.with_daemon_stopped

Use systemctl to check gpumon's status

(*
 * Copyright (C) 2006-2013 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 D = Debug.Make(struct let name="xapi" end)
open D

let systemctl = "/usr/bin/systemctl"
let gpumon = "xcp-rrdd-gpumon"

module Gpumon = Daemon_manager.Make(struct
	let check = Daemon_manager.Function (fun () ->
		try
			ignore
				(Forkhelpers.execute_command_get_output systemctl
					["is-active"; "-q"; gpumon]);
			true
		with _ -> false)

	let start () =
		debug "Starting %s" gpumon;
		ignore (Forkhelpers.execute_command_get_output systemctl ["start"; gpumon])

	let stop () =
		debug "Stopping %s" gpumon;
		ignore (Forkhelpers.execute_command_get_output systemctl ["stop"; gpumon])
end)

let with_gpumon_stopped = Gpumon.with_daemon_stopped


open OUnit2

let test1 test_ctxt = assert_equal 0 0

let suite =
    "VyConf tree tests" >::: [
        "test_dummy">:: test1;
    ]

let () =
  run_test_tt_main suite

Add the first actual unit test.

open OUnit2
open Vytree

let test1 test_ctxt = assert_equal 0 0

let test_make_node test_ctxt =
    let node = make "root" () in
    assert_equal (name_of_node node) "root";
    assert_equal (data_of_node node) ();
    assert_equal (children_of_node node) []

let suite =
    "VyConf tree tests" >::: [
        "test_make_node" >:: test_make_node;
    ]

let () =
  run_test_tt_main suite


(** Main for CATT. *)
open Common

let parse_file f =
  let sin =
    let fi = open_in f in
    let flen = in_channel_length fi in
    let buf = Bytes.create flen in
    really_input fi buf 0 flen;
    close_in fi;
    buf
  in
  Prover.parse sin

let usage = "catt [file]"

let () =
  Printexc.record_backtrace true;
  let file_in = ref [] in
  Arg.parse
    []
    (fun s -> file_in := s::!file_in)
    usage;
  let _ = match !file_in with
    | [f] -> Command.exec (parse_file f)
| _ -> ()
  in ()

Correct bytes / string conversion.

(** Main for CATT. *)
open Common

let parse_file f =
  let sin =
    let fi = open_in f in
    let flen = in_channel_length fi in
    let buf = Bytes.create flen in
    really_input fi buf 0 flen;
    close_in fi;
    buf
  in
  Prover.parse (Bytes.to_string sin)

let usage = "catt [file]"

let () =
  Printexc.record_backtrace true;
  let file_in = ref [] in
  Arg.parse
    []
    (fun s -> file_in := s::!file_in)
    usage;
  let _ = match !file_in with
    | [f] -> Command.exec (parse_file f)
| _ -> ()
  in ()


type t
val init_plus : string -> t
val transform :
  t -> t -> float array -> float array -> float array * float array
val is_latlong : t -> bool
val is_geocent : t -> bool
val get_def : t -> string
val latlong_from_proj : t -> t

Add some basic documentation comments

type t
(** A type defining a projection *)

val init_plus : string -> t
(** [init_plus def] creates a projection based on the specs in [def]. *)

val transform :
  t -> t -> float array -> float array -> float array * float array
(** [transform src dest xs ys] transforms the points [xs], [ys]
    from [src] coordinate system to the [dest] coordinate system. *)

val is_latlong : t -> bool
(** [is_latlong t] returns [true] if [t] is geographic. *)

val is_geocent : t -> bool
(** [is_geocent t] returns [true] if [t] is geocentric. *)

val get_def : t -> string
(** [get_def t] returns a definition string appropriate for passing to
    {!init_plus}. *)

val latlong_from_proj : t -> t
(** [latlong_from_proj t] returns the geographic coordinate system underlying
    [t]. *)


open Source

let print vs =
  List.iter Print.print_value (List.map (fun v -> Some v) vs);
  None

let match_import i =
  let {Ast.module_name; func_name; func_params; func_result} = i.it in
  if module_name <> "stdio" then
    Error.error i.at ("no builtin module \"" ^ module_name ^ "\"");
  match func_name with
  | "print" ->
    if func_result <> None then
      Error.error i.at "stdio.print has no result";
    print
  | _ ->
    Error.error i.at ("no stdio." ^ func_name ^ "\"")

let match_imports (is : Ast.import list) =
  List.map match_import is

Fix a missing quote in an error message.

open Source

let print vs =
  List.iter Print.print_value (List.map (fun v -> Some v) vs);
  None

let match_import i =
  let {Ast.module_name; func_name; func_params; func_result} = i.it in
  if module_name <> "stdio" then
    Error.error i.at ("no builtin module \"" ^ module_name ^ "\"");
  match func_name with
  | "print" ->
    if func_result <> None then
      Error.error i.at "stdio.print has no result";
    print
  | _ ->
    Error.error i.at ("no \"stdio." ^ func_name ^ "\"")

let match_imports (is : Ast.import list) =
  List.map match_import is


module C = Cohttp_lwt_unix
open Cohttp_lwt_unix_io

let base_uri = "http://ws.spotify.com/search/1/"

type search_mode = [ `album | `artist | `track ]

let string_of_mode = function
  | `album -> "album"
  | `artist -> "artist"
  | `track -> "track"

exception No_response

let search mode query parse_fn =
  let uri = Uri.of_string
    (Printf.sprintf "%s%s.json?q=%s"
      base_uri (string_of_mode mode) query)
  in
  C.Client.call ~chunked:false `GET uri
  >>= (fun result ->
    match result with
    | Some (_, body) ->
      C.Body.string_of_body body
      >>= (fun data -> return (parse_fn data))
    | None -> Lwt.fail No_response)

let search_albums query =
  search `album query Spotify_search_j.album_search_of_string

let search_artists query =
  search `artist query Spotify_search_j.artist_search_of_string

let search_tracks query =
  search `track query Spotify_search_j.track_search_of_string

Update to work with cohttp changes

module C = Cohttp_lwt_unix
open Cohttp_lwt_unix_io

let base_uri = "http://ws.spotify.com/search/1/"

type search_mode = [ `album | `artist | `track ]

let string_of_mode = function
  | `album -> "album"
  | `artist -> "artist"
  | `track -> "track"

exception No_response

let search mode query parse_fn =
  let uri = Uri.of_string
    (Printf.sprintf "%s%s.json?q=%s"
      base_uri (string_of_mode mode) query)
  in
  C.Client.call ~chunked:false `GET uri
  >>= (fun result ->
    match result with
    | Some (_, body) ->
      Cohttp_lwt_body.string_of_body body
      >>= (fun data -> return (parse_fn data))
    | None -> Lwt.fail No_response)

let search_albums query =
  search `album query Spotify_search_j.album_search_of_string

let search_artists query =
  search `artist query Spotify_search_j.artist_search_of_string

let search_tracks query =
  search `track query Spotify_search_j.track_search_of_string


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

(** An execution history is a current instruction pointer and some
    predecessors. [preds] are empty iff this is an entrypoint. *)
type t = Init | Step of {curr: Llair.IP.t; preds: t iarray}
[@@deriving sexp_of]

let init = Init
let extend curr preds = Step {curr; preds= IArray.of_list preds}

let dump h fs =
  (* todo: output nicely-formatted DAG; just printing a single
     arbitrarily-chosen witness path from the root for now. *)
  let path =
    let rec path_impl = function
      | Init -> []
      | Step {curr; preds} ->
          let tail =
            if IArray.is_empty preds then []
            else path_impl (IArray.get preds 0)
          in
          if Llair.IP.index curr = 0 || IArray.length preds > 1 then
            curr :: tail
          else tail
    in
    path_impl >> List.rev
  in
  let pp_ip fs ip =
    let open Llair in
    Format.fprintf fs "%a%a%a" FuncName.pp (IP.block ip).parent.name IP.pp
      ip Loc.pp (IP.loc ip)
  in
  Format.fprintf fs "@[<v 2>Witness Trace:@ %a@]" (List.pp "@ " pp_ip)
    (path h)

Improve formatting and print indices of witness traces

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

(** An execution history is a current instruction pointer and some
    predecessors. [preds] are empty iff this is an entrypoint. *)
type t = Init | Step of {curr: Llair.IP.t; preds: t iarray}
[@@deriving sexp_of]

let init = Init
let extend curr preds = Step {curr; preds= IArray.of_list preds}

let dump h fs =
  (* todo: output nicely-formatted DAG; just printing a single
     arbitrarily-chosen witness path from the root for now. *)
  let path =
    let rec path_impl = function
      | Init -> []
      | Step {curr; preds} ->
          let tail =
            if IArray.is_empty preds then []
            else path_impl (IArray.get preds 0)
          in
          if Llair.IP.index curr = 0 || IArray.length preds > 1 then
            curr :: tail
          else tail
    in
    path_impl >> List.rev
  in
  let pp_ip fs ip =
    let open Llair in
    let block = IP.block ip in
    Format.fprintf fs "#%-8i%a%a" block.sort_index FuncName.pp
      block.parent.name Loc.pp (IP.loc ip)
  in
  let pp_path fs =
    List.iteri ~f:(fun idx ip -> Format.fprintf fs "@ %i:\t%a" idx pp_ip ip)
  in
  Format.fprintf fs "@[<v 2>Witness Trace:%a@]" pp_path (path h)


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

type request =
  | Subscribe
  | Autocomplete of (File_input.t * (* request id *) int)
  | DidOpen of (* filename *) string Nel.t
  | DidClose of (* filename *) string Nel.t

type response =
  | Errors of {errors: Errors.ErrorSet.t; warnings: Errors.ErrorSet.t}
  | StartRecheck
  | EndRecheck
  | AutocompleteResult of (ServerProt.autocomplete_response * (* request id *) int)
  | DidOpenAck
  | DidCloseAck

Add client_id & debug functions to Persistent_connection_prot

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

type client_id = int

type request =
  | Subscribe
  | Autocomplete of (File_input.t * (* request id *) int)
  | DidOpen of (* filename *) string Nel.t
  | DidClose of (* filename *) string Nel.t

let string_of_request = function
| Subscribe -> "subscribe"
| Autocomplete _ -> "autocomplete"
| DidOpen _ -> "didOpen"
| DidClose _ -> "didClose"

type response =
  | Errors of {errors: Errors.ErrorSet.t; warnings: Errors.ErrorSet.t}
  | StartRecheck
  | EndRecheck
  | AutocompleteResult of (ServerProt.autocomplete_response * (* request id *) int)
  | DidOpenAck
  | DidCloseAck

let string_of_response = function
| Errors _ -> "errors"
| StartRecheck -> "startRecheck"
| EndRecheck -> "endRecheck"
| AutocompleteResult _ -> "autocompleteResult"
| DidOpenAck -> "didOpenAck"
| DidCloseAck -> "didCloseAck"


let time_service host sheet =
  let path = Some ("time/" ^ sheet) in
  Http.json_get_service host path None

let time host sheet =
  let code,host,json = time_service host sheet in
  match code with
    200 ->  Time.time_of_json json
  | _   ->  raise Http.Connection_failure

Add error code in the exception

let time_service host sheet =
  let path = Some ("time/" ^ sheet) in
  Http.json_get_service host path None

let time host sheet =
  let code,host,json = time_service host sheet in
  match code with
    200 ->  Time.time_of_json json
  | c   ->  raise (Http.Connection_failure c)


(* the token list contains also the comment-tokens *)
type program2 = Ast_java.program option * Parser_java.token list

exception Parse_error of Parse_info.info

(* This is the main function *)
val parse :
  Common.filename (*javafile*) -> (program2 * Parse_info.parsing_stat)

(* may return "just:pb" exn when program2 was a None *)
val parse_program:
  Common.filename -> Ast_java.program

(* for generalized sgrep/spatch patterns *)
val parse_fuzzy:
  Common.filename -> Ast_fuzzy.tree list * Parser_java.token list

(* internal *)
val tokens: Common.filename -> Parser_java.token list
(* useful for unit testing, mock *)
val tmp_file_from_string: string -> Common.filename

Add program_of_program2 to the interface for Parse_java

(* the token list contains also the comment-tokens *)
type program2 = Ast_java.program option * Parser_java.token list

exception Parse_error of Parse_info.info

(* This is the main function *)
val parse :
  Common.filename (*javafile*) -> (program2 * Parse_info.parsing_stat)

(* may return "just:pb" exn when program2 was a None *)
val parse_program:
  Common.filename -> Ast_java.program

(* for generalized sgrep/spatch patterns *)
val parse_fuzzy:
  Common.filename -> Ast_fuzzy.tree list * Parser_java.token list

val program_of_program2 : program2 -> Ast_java.program

(* internal *)
val tokens: Common.filename -> Parser_java.token list
(* useful for unit testing, mock *)
val tmp_file_from_string: string -> Common.filename


module X = Test_interface

open OUnit

let all_tests =
  [
    Test_pervasives.tests;
(*    Test_base64.tests; Replaced by simple quickcheck rules inline *)
 (*   Test_unix.tests; Moved to inline tests in BatUnix *)
(*    Test_print.tests;
    Test_toplevel.tests; *)
    Test_map.tests;
    (* pmap is actually tested in test_map.ml, as they share their
       implementation *)
    Test_multipmap.tests;
(*     Test_vect.tests; Moved inline to BatVect *)
    Test_file.tests;
(*    Test_string.tests; Moved inline to BatString *)
    Test_substring.tests;
    Test_digest.tests;
    Test_enum.tests;
    Test_set.tests;
    Test_dynarray.tests;
    Test_stack.tests;
    Test_mappable.tests;
    Test_hashcons.tests;
    Test_mapfunctors.tests;
    Test_lazy_pattern.tests;
    Test_optparse.tests;
    Test_uref.tests;
  ]

let () =
  ignore(OUnit.run_test_tt_main ("All" >::: all_tests));

Add entry point for bitset tests.

module X = Test_interface

open OUnit

let all_tests =
  [
    Test_pervasives.tests;
(*    Test_base64.tests; Replaced by simple quickcheck rules inline *)
 (*   Test_unix.tests; Moved to inline tests in BatUnix *)
(*    Test_print.tests;
    Test_toplevel.tests; *)
    Test_map.tests;
    (* pmap is actually tested in test_map.ml, as they share their
       implementation *)
    Test_multipmap.tests;
(*     Test_vect.tests; Moved inline to BatVect *)
    Test_file.tests;
(*    Test_string.tests; Moved inline to BatString *)
    Test_substring.tests;
    Test_digest.tests;
    Test_enum.tests;
    Test_set.tests;
    Test_dynarray.tests;
    Test_stack.tests;
    Test_mappable.tests;
    Test_hashcons.tests;
    Test_mapfunctors.tests;
    Test_lazy_pattern.tests;
    Test_optparse.tests;
    Test_uref.tests;
    Test_bitset.tests;
  ]

let () =
  ignore(OUnit.run_test_tt_main ("All" >::: all_tests));


let _ =
  CmdLineParser.parse_cmdline [
      ("mul2", (fun win -> X64_FastMul.va_code_fast_mul_stdcall win));
      ("sqr",  (fun win -> X64_FastSqr.va_code_fast_sqr_stdcall win));
(*
      ("mul1", (fun win -> X64_FastMul.va_code_fast_mul1_stdcall win));
      ("add1", (fun win -> X64_FastMul.va_code_fast_add1_stdcall win));
      ("add",  (fun win -> X64_FastMul.va_code_fast_add_stdcall win));
*)
    ]

Fix module names so that Util functions extract

let _ =
  CmdLineParser.parse_cmdline [
      ("mul2", (fun win -> X64_FastMul.va_code_fast_mul_stdcall win));
      ("sqr",  (fun win -> X64_FastSqr.va_code_fast_sqr_stdcall win));
      ("mul1", (fun win -> X64_FastUtil.va_code_fast_mul1_stdcall win));
      ("add1", (fun win -> X64_FastUtil.va_code_fast_add1_stdcall win));
      ("add",  (fun win -> X64_FastUtil.va_code_fast_add_stdcall win));
    ]


(*
 * 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 Memory_interface
open Xenops_utils

module D = Debug.Make(struct let name = "memory_client" end)
open D
module E = Debug.Make(struct let name = "mscgen" end)

let json_url () = "file:" ^ json_path

let json_binary_rpc = Xenops_client.binary_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string

module Client = Memory_interface.Client(struct let rpc = json_binary_rpc ~srcstr:"xenops" ~dststr:"squeezed" json_url end)

Update to use Xcp_client rather than Xenops_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 Memory_interface

let json_url () = "file:" ^ json_path

let json_binary_rpc = Xcp_client.binary_rpc Jsonrpc.string_of_call Jsonrpc.response_of_string

module Client = Memory_interface.Client(struct let rpc = json_binary_rpc ~srcstr:"xenops" ~dststr:"squeezed" json_url end)


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

Remove polymorphics_arg, it's just a type_name list. Update the comments.

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

(* Kind definition *)

(* An atom cannot be parametrized by types. *)
(* kind List: type -> type *)
(* kind Variable: atom *)
type kind =
  | Type of type_binders
  | Atom

(* Type application *)
(* A type application is the process to apply a type to another. *)
(* Example: forall(A).List<A> *)
type type_application = type_name * type_name list

(* Constant definition *)

type constant = type_binders * type_application

(* Operator definition *)

(* A binder is: "Variable" in [Variable].Term * Term -> Term.
 (Note the '.' that delimitates 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


open Cil

(* TODO: detect temporaries created by Cil? *)
(* let var_is_tmp {vdescrpure} = not vdescrpure (* doesn't exclude tmp___0 *) *)
let tmp_var_regexp = Str.regexp "^\\(tmp\\(___[0-9]+\\)?\\|cond\\|RETURN\\)$"
let var_is_tmp {vname} = Str.string_match tmp_var_regexp vname 0
let rec exp_contains_tmp = function
  | Lval (Var vi, _) -> var_is_tmp vi
  | UnOp (_, e, _) -> exp_contains_tmp e
  | BinOp (_, e1, e2, _) -> exp_contains_tmp e1 || exp_contains_tmp e2
  | exp -> exp = MyCFG.unknown_exp

Add comment about CIL and its temporary variables

open Cil

(* TODO: detect temporaries created by Cil? *)
(* let var_is_tmp {vdescrpure} = not vdescrpure (* doesn't exclude tmp___0 *) *)
(* TODO: instead check if vdescr is nonempty? (doesn't cover all cases, e.g. ternary temporary) *)
let tmp_var_regexp = Str.regexp "^\\(tmp\\(___[0-9]+\\)?\\|cond\\|RETURN\\)$"
let var_is_tmp {vname} = Str.string_match tmp_var_regexp vname 0
let rec exp_contains_tmp = function
  | Lval (Var vi, _) -> var_is_tmp vi
  | UnOp (_, e, _) -> exp_contains_tmp e
  | BinOp (_, e1, e2, _) -> exp_contains_tmp e1 || exp_contains_tmp e2
  | exp -> exp = MyCFG.unknown_exp


open Client
open Quicktest_common

(* alias PBD module for convenience
 * also has scope for generalising verification
 * between PBDs and VBDs for common API calls
 * e.g. both have get_uuid, get_other_config etc. *)
module P = Client.PBD

let start session_id rpc =

  (* helper functions for API/PBD calls *)
  let with_api fn = fn ~rpc ~session_id in
  let with_pbd fn pbd = with_api fn ~self:pbd in

  (* checks get_uuid returns correct UUID by comparing
   * the PBD returned by get_by_uuid *)
  let uuid_test pbd =
    let uuid_t = make_test "Testing 'get_by_uuid', 'get_uuid'" 4 in
    try
      start uuid_t;
      let uuid = with_pbd P.get_uuid pbd in
      if with_api P.get_by_uuid ~uuid = pbd
      then success uuid_t
      else failed uuid_t "'get_by_uuid' failed";
    with e -> failed uuid_t (ExnHelper.string_of_exn e); in

  (* main function to run test suite *)
  let run_tests () =
    let test = make_test "Begin PBD verification" 2 in
    try
      start test;
      let pbd = List.hd (with_api P.get_all) in
      uuid_test pbd;
      debug test "PBD verification complete";
      success test;
    with
    | (Failure hd) -> failed test "Error: no PBD available"
    | e -> failed test (ExnHelper.string_of_exn e);
  in run_tests () ;

Mark as educational example of quicktest code

(* demonstrative example of how quicktest code should be written *)
open Client
open Quicktest_common

(* alias PBD module for convenience *)
module P = Client.PBD

let start session_id rpc =

  (* helper functions for API/PBD calls *)
  let with_api fn = fn ~rpc ~session_id in
  let with_pbd fn pbd = with_api fn ~self:pbd in

  (* checks get_uuid returns correct UUID by comparing
   * the PBD returned by get_by_uuid *)
  let uuid_test pbd =
    let uuid_t = make_test "Testing 'get_by_uuid', 'get_uuid'" 4 in
    try
      start uuid_t;
      let uuid = with_pbd P.get_uuid pbd in
      if with_api P.get_by_uuid ~uuid = pbd
      then success uuid_t
      else failed uuid_t "'get_by_uuid' failed";
    with e -> failed uuid_t (ExnHelper.string_of_exn e); in

  (* main function to run test suite *)
  let run_tests () =
    let test = make_test "Begin PBD verification" 2 in
    try
      start test;
      let pbd = List.hd (with_api P.get_all) in
      uuid_test pbd;
      debug test "PBD verification complete";
      success test;
    with
    | (Failure hd) -> failed test "Error: no PBD available"
    | e -> failed test (ExnHelper.string_of_exn e);
  in run_tests () ;


(**
 * 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 "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

(*****************************************************************************)
(* The file extensions we are interested in *)
(*****************************************************************************)

let extensions = [
  ".php"  ; (* normal php file *)
  ".hh"   ; (* Hack extension some open source code is starting to use *)
  ".phpt" ; (* our php template files *)
  ".hhi"  ; (* interface files only visible to the type checker *)
]

let is_directory path = try Sys.is_directory path with Sys_error _ -> false

let is_dot_file path =
  let filename = Filename.basename path in
  String.length filename > 0 && filename.[0] = '.'

let is_php path =
  not (is_dot_file path) &&
  List.exists (Filename.check_suffix path) extensions &&
  not (is_directory path) &&
  not (FilesToIgnore.should_ignore path)

let is_js path =
  not (is_dot_file path) &&
  Filename.check_suffix path ".js" &&
  not (is_directory path)

Allow hh_server to find files with a .xhp extension

(**
 * 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 "hack" directory of this source tree. An additional grant
 * of patent rights can be found in the PATENTS file in the same directory.
 *
 *)

(*****************************************************************************)
(* The file extensions we are interested in *)
(*****************************************************************************)

let extensions = [
  ".php"  ; (* normal php file *)
  ".hh"   ; (* Hack extension some open source code is starting to use *)
  ".phpt" ; (* our php template files *)
  ".hhi"  ; (* interface files only visible to the type checker *)
  ".xhp"  ; (* XHP extensions *)
]

let is_directory path = try Sys.is_directory path with Sys_error _ -> false

let is_dot_file path =
  let filename = Filename.basename path in
  String.length filename > 0 && filename.[0] = '.'

let is_php path =
  not (is_dot_file path) &&
  List.exists (Filename.check_suffix path) extensions &&
  not (is_directory path) &&
  not (FilesToIgnore.should_ignore path)

let is_js path =
  not (is_dot_file path) &&
  Filename.check_suffix path ".js" &&
  not (is_directory path)


let () = Printexc.record_backtrace true

let config_log verbosity =
  Log.current_level := Log.level_of_str verbosity

let hdhcpd verbosity =
  let () = config_log verbosity in
  let () = Log.notice "Haesbaert DHCPD started" in
  Lwt_main.run (Log.notice_lwt "Haesbaert DHCP finished")

(* Parse command line and start the ball *)
open Cmdliner
let cmd =
  let verbosity = Arg.(value & opt string "notice" & info ["v" ; "verbosity"]
                         ~doc:"Log verbosity, debug|info|notice") in
  Term.(pure hdhcpd $ verbosity),
  Term.info "hdhcpd" ~version:"0.1" ~doc:"Haesbaert DHCP"
let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0

Implement open_dhcp_sock and start reading packets.

open Lwt

let () = Printexc.record_backtrace true

let config_log verbosity =
  Log.current_level := Log.level_of_str verbosity

let open_dhcp_sock () =
  let open Lwt_unix in
  let sock = socket PF_INET SOCK_DGRAM 0 in
  let () = setsockopt sock SO_REUSEADDR true in
  let () = bind sock (ADDR_INET (Unix.inet_addr_any, 67)) in
  sock

let rec dhcp_recv sock =
  let buffer_size = 2048 in
  let buffer = Bytes.create buffer_size in
  lwt n = Lwt_unix.read sock buffer 0 buffer_size in
  let () = Log.debug "dhcp sock read %d bytes" n in
  let () = if n = 0 then
      failwith "Unexpected EOF in DHCPD socket" in
  dhcp_recv sock

let hdhcpd verbosity =
  let () = config_log verbosity in
  let () = Log.notice "Haesbaert DHCPD started" in
  let sock = open_dhcp_sock () in
  let recv_thread = dhcp_recv sock in
  Lwt_main.run (recv_thread >>= fun () ->
    Log.notice_lwt "Haesbaert DHCP finished")

(* Parse command line and start the ball *)
open Cmdliner
let cmd =
  let verbosity = Arg.(value & opt string "notice" & info ["v" ; "verbosity"]
                         ~doc:"Log verbosity, debug|info|notice") in
  Term.(pure hdhcpd $ verbosity),
  Term.info "hdhcpd" ~version:"0.1" ~doc:"Haesbaert DHCP"
let () = match Term.eval cmd with `Error _ -> exit 1 | _ -> exit 0


type heap = unit

(* https://www.lexifi.com/blog/references-physical-equality *)
type 'a ref = {
  mutable contents: 'a;
  id: int
}

type ('a, 'b) mref = 'a ref

let emp =
  ()

(* Logical functions on heap *)
(* TODO : complete the functions to have the same interface as in FStar.Heap.fsti *)

let addr_of _ = Obj.magic ()
let is_mm _ = Obj.magic ()

(* let compare_addrs *)

type ('a, 'b, 'c, 'd) contains
type ('a, 'b, 'c, 'd) unused_in
let fresh _ _ _ = Obj.magic ()

let sel _ _ = Obj.magic ()
let upd _ _ _ = Obj.magic ()
let alloc _ _ _ = Obj.magic ()

(* Untyped view of references *)
type aref =
   | Ref of (unit * unit)
let dummy_aref = Ref ((), ())
let aref_of _ = dummy_aref
let ref_of _ _ = Obj.magic ()

Add missing dummy extracted type

type heap = unit

(* https://www.lexifi.com/blog/references-physical-equality *)
type 'a ref = {
  mutable contents: 'a;
  id: int
}

type ('a, 'b) mref = 'a ref

let emp =
  ()

(* Logical functions on heap *)
(* TODO : complete the functions to have the same interface as in FStar.Heap.fsti *)

let addr_of _ = Obj.magic ()
let is_mm _ = Obj.magic ()

(* let compare_addrs *)

type ('a, 'b, 'c, 'd) contains
type ('a, 'b) addr_unused_in
type ('a, 'b, 'c, 'd) unused_in
let fresh _ _ _ = Obj.magic ()

let sel _ _ = Obj.magic ()
let upd _ _ _ = Obj.magic ()
let alloc _ _ _ = Obj.magic ()

(* Untyped view of references *)
type aref =
   | Ref of (unit * unit)
let dummy_aref = Ref ((), ())
let aref_of _ = dummy_aref
let ref_of _ _ = Obj.magic ()


open Color
open Core

type t =
  | Bar of color
  | Point of point_int
  | Home of color
[@@deriving sexp, compare]
and point_int = int

let point n =
  if 1 <= n && n <= 24 then Point n else invalid_arg "Invalid point"

let valid_points =
  (List.map ~f:(fun x-> Point x) (List.range ~stop:`inclusive 1 24))

let valid : t list =
  [Bar White; Bar Black]
  @ valid_points
  @ [Home White; Home Black]

let find_dest source steps c =
  let step_fn = match c with | White -> (-) | Black -> (+) in
  match source with
  | Bar White -> Some (Point steps)
  | Bar Black -> Some (Point (-steps))
  | Point (start) -> let dest = step_fn (start :> int) steps in
    let open Int in
    if dest >= 1 && dest <= 24 then Some (Point dest) else Some (Home c)
  | Home _ -> None

Fix calculation of destination from bar

open Color
open Core

type t =
  | Bar of color
  | Point of point_int
  | Home of color
[@@deriving sexp, compare]
and point_int = int

let point n =
  if 1 <= n && n <= 24 then Point n else invalid_arg "Invalid point"

let valid_points =
  (List.map ~f:(fun x-> Point x) (List.range ~stop:`inclusive 1 24))

let valid : t list =
  [Bar White; Bar Black]
  @ valid_points
  @ [Home White; Home Black]

let find_dest source steps c =
  let step_fn = match c with | White -> (-) | Black -> (+) in
  match source with
  | Bar White -> Some (Point (25 - steps))
  | Bar Black -> Some (Point steps)
  | Point (start) -> let dest = step_fn (start :> int) steps in
    let open Int in
    if dest >= 1 && dest <= 24 then Some (Point dest) else Some (Home c)
  | Home _ -> None


open Color
open Core

module T : sig
  type t =
    | Bar of color
    | Point of point_int
    | Home of color
  [@@deriving sexp, compare]
  and point_int = private int
  val point : int -> t
end = struct
  type t =
    | Bar of color
    | Point of point_int
    | Home of color
  [@@deriving sexp, compare]
  and point_int = int
  let point n =
    if 1 <= n && n <= 24 then Point n else invalid_arg "Invalid point"
end

include T;;

let valid : t list =
  [Bar White; Bar Black]
  @ (List.map ~f:(fun x -> point x) (List.range ~stop:`inclusive 1 24))
  @ [Home White; Home Black]

let find_dest source steps c =
  let step_fn = match c with | White -> (+) | Black -> (-) in
  match source with
  | Bar White -> Some (point steps)
  | Bar Black -> Some (point (-steps))
  | Point (start) -> let dest = step_fn (start :> int) steps in
    let open Int in
    if dest >= 1 && dest <= 24 then Some (point dest) else Some (Home c)
  | Home _ -> None

Fix Location.find_dest walking in wrong direction

open Color
open Core

module T : sig
  type t =
    | Bar of color
    | Point of point_int
    | Home of color
  [@@deriving sexp, compare]
  and point_int = private int
  val point : int -> t
end = struct
  type t =
    | Bar of color
    | Point of point_int
    | Home of color
  [@@deriving sexp, compare]
  and point_int = int
  let point n =
    if 1 <= n && n <= 24 then Point n else invalid_arg "Invalid point"
end

include T;;

let valid : t list =
  [Bar White; Bar Black]
  @ (List.map ~f:(fun x -> point x) (List.range ~stop:`inclusive 1 24))
  @ [Home White; Home Black]

let find_dest source steps c =
  let step_fn = match c with | White -> (-) | Black -> (+) in
  match source with
  | Bar White -> Some (point steps)
  | Bar Black -> Some (point (-steps))
  | Point (start) -> let dest = step_fn (start :> int) steps in
    let open Int in
    if dest >= 1 && dest <= 24 then Some (point dest) else Some (Home c)
  | Home _ -> None


open Mirage

let main = foreign ~deps:[abstract nocrypto] "Unikernel.Main" (random @-> job)

let () =
  let packages = [
    package "randomconv" ;
    package "mirage-entropy" ;
    (* access to entropy sources is only via Nocrypto_entropy_mirage.sources,
       which is only compiled when nocrypto uses xen or freestanding flags *)
    package ~ocamlfind:[] "ocaml-freestanding" ;
    package ~sublibs:["mirage"] "nocrypto"
  ] in
  register ~packages "prng" [main $ default_random]

Build fix attempt: nocrypto moved to mirage-solo5

open Mirage

let main = foreign ~deps:[abstract nocrypto] "Unikernel.Main" (random @-> job)

let () =
  let packages = [
    package "randomconv" ;
    package "mirage-entropy" ;
    (* access to entropy sources is only via Nocrypto_entropy_mirage.sources,
       which is only compiled when nocrypto uses xen or freestanding flags *)
    package ~ocamlfind:[] "mirage-solo5" ;
    package ~sublibs:["mirage"] "nocrypto"
  ] in
  register ~packages "prng" [main $ default_random]


(** Contient les types des objets qui seront ensuite manipulés *)

module Env = BatMap.Make(BatString)

(** type des expressions arithmetiques *)
type arit_expr = float Env.t -> float

type rule = {
	left_mem : string ;
	var : string list ;
	right_mem : (string * (arit_expr list)) list ;
	}

(** type lsystem utilisé dans le parser *)
type lsystem = {
	name : string ;
	axiom : (string * (float list)) list ;
	rules : rule list
	}

Change lilis according to mini_calc's modifications.

(** Contient les types des objets qui seront ensuite manipulés *)

module Env = Mini_calc.Env

(** type des expressions arithmetiques *)
type arit_expr = Mini_calc.arit_env -> float

type rule = {
	left_mem : string ;
	var : string list ;
	right_mem : (string * (arit_expr list)) list ;
	}

(** type lsystem utilisé dans le parser *)
type lsystem = {
	name : string ;
	axiom : (string * (float list)) list ;
	rules : rule list
	}


include Amqp_client_lib.Thread.T with type 'a Deferred.t = 'a Async_kernel.Deferred.t

Make types non-opaque for async version to allow using Async function on eg. pipes

include Amqp_client_lib.Thread.T
  with type 'a Deferred.t = 'a Async_kernel.Deferred.t
  and type Writer.t = Async.Writer.t
  and type Reader.t = Async.Reader.t
  and type 'a Pipe.Reader.t = 'a Async.Pipe.Reader.t
  and type 'a Pipe.Writer.t = 'a Async.Pipe.Writer.t
  and type 'a Ivar.t = 'a Async_kernel.Ivar.t


let greet subject =
  match subject with
  | None    -> "Hello, World!"
  | Some(s) -> String.concat "" ["Hello, "; s; "!"]

Use ^ as concatenation operator

let greet subject =
  match subject with
  | None    -> "Hello, World!"
  | Some(s) -> "Hello, " ^ s ^ "!"


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

type context = {
  in_synchronized_block: bool;

  (*
   * True if the translation unit contains an ObjC class impl that's a subclass
   * of CKComponent or CKComponentController.
   *)
  is_ck_translation_unit: bool;
}

let empty = {
  in_synchronized_block = false;
  is_ck_translation_unit = false;
}

Fix comment formatting for linter context

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

type context = {
  in_synchronized_block: bool;
  is_ck_translation_unit: bool;
  (** True if the translation unit contains an ObjC class impl that's a subclass
      of CKComponent or CKComponentController. *)
}

let empty = {
  in_synchronized_block = false;
  is_ck_translation_unit = false;
}


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

val key : allow_optional:bool -> ('loc, 'loc) Flow_ast.Expression.t -> Key.t option

val get :
  allow_optional:bool -> Context.t -> ('loc, 'loc) Flow_ast.Expression.t -> ALoc.t -> Type.t option

val key_of_pattern : allow_optional:bool -> ('loc, 'loc) Flow_ast.Pattern.t -> Key.t option

val get_of_pattern :
  allow_optional:bool -> Context.t -> ('loc, 'loc) Flow_ast.Pattern.t -> ALoc.t -> Type.t option

Make Refinement API accept typed AST as well

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

val key : allow_optional:bool -> ('loc, 't) Flow_ast.Expression.t -> Key.t option

val get :
  allow_optional:bool -> Context.t -> ('loc, 't) Flow_ast.Expression.t -> ALoc.t -> Type.t option

val key_of_pattern : allow_optional:bool -> ('loc, 't) Flow_ast.Pattern.t -> Key.t option

val get_of_pattern :
  allow_optional:bool -> Context.t -> ('loc, 't) Flow_ast.Pattern.t -> ALoc.t -> Type.t option


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

exception Worker_should_exit

let () = Callback.register_exception "worker_should_exit" Worker_should_exit

external stop_workers : unit -> unit = "hh_stop_workers"

external resume_workers : unit -> unit = "hh_resume_workers"

external check_should_exit : unit -> unit = "hh_check_should_exit"

external set_can_worker_stop : bool -> unit = "hh_set_can_worker_stop"

let on_worker_cancelled = ref (fun () -> ())

let set_on_worker_cancelled f = on_worker_cancelled := f

let with_no_cancellations f =
  Utils.try_finally
    ~f:
      begin
        fun () ->
        set_can_worker_stop false;
        f ()
      end
    ~finally:(fun () -> set_can_worker_stop true)

let with_worker_exit f =
  try f ()
  with Worker_should_exit ->
    !on_worker_cancelled ();
    exit 0

(* Check if the workers are stopped and exit if they are *)
let check_should_exit () = with_worker_exit check_should_exit

Add check_should_exit to the end of with_no_cancellations

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

exception Worker_should_exit

let () = Callback.register_exception "worker_should_exit" Worker_should_exit

external stop_workers : unit -> unit = "hh_stop_workers"

external resume_workers : unit -> unit = "hh_resume_workers"

external check_should_exit : unit -> unit = "hh_check_should_exit"

external set_can_worker_stop : bool -> unit = "hh_set_can_worker_stop"

let on_worker_cancelled = ref (fun () -> ())

let set_on_worker_cancelled f = on_worker_cancelled := f

let with_worker_exit f =
  try f ()
  with Worker_should_exit ->
    !on_worker_cancelled ();
    exit 0

(* Check if the workers are stopped and exit if they are *)
let check_should_exit () = with_worker_exit check_should_exit

let with_no_cancellations f =
  Utils.try_finally
    ~f:
      begin
        fun () ->
        set_can_worker_stop false;
        f ()
      end
    ~finally:(fun () ->
      set_can_worker_stop true;
      check_should_exit ())


module Type = struct
  type t = Int | String
end

module AnnotationCons (A : sig type t end) (B : sig type t end) = struct
  type t = A.t * B.t
end

module Location = struct
  type t = int * int
end

module AST (T : sig type t end) = struct
  type name = string
  type var = name * Type.t
  type op =
    | Plus
    | Minus
    | Times
    | Div
  type exp =
    | IntLit of int
    | CharLit of char
    | Var of name
    | InfixOper of op * exp * exp
    | Funcall of name * exp list
  type statement =
    | Assignment of var * exp
    | If of exp * statement list * statement list
    | Return of exp
    | Exp of exp
  type function_def = Fun of name * var list * Type.t * statement list
  type program = Prog of function_def list
  type t = T.t * program
end

module TypedAst = AST(AnnotationCons(Type)(Location))

let () =
  let open TypedAst in
  let prog = Prog
    [
      Fun ("main", [], Type.Int, [
        Return (IntLit 0)
      ])
    ] in
    ignore prog

Make the code more interesting

module Type = struct
  type t = Int | String
end

module AnnotationCons (A : sig type t end) (B : sig type t end) = struct
  type t = A.t * B.t
end

module Location = struct
  type t = int * int
end

module AST (T : sig type t end) = struct
  type name = string
  type var = name * Type.t
  type op =
    | Plus
    | Minus
    | Times
    | Div
  type exp =
    | IntLit of int
    | CharLit of char
    | Var of name
    | InfixOper of op * exp * exp
    | Funcall of name * exp list
  type statement =
    | Assignment of var * exp
    | If of exp * statement list * statement list
    | Return of exp
    | Exp of exp
  type function_def = Fun of name * var list * Type.t * statement list
  type program = Prog of function_def list
  type t = T.t * program
end

module TypedAst = AST(AnnotationCons(Type)(Location))

let () =
  let open TypedAst in
  let prog = Prog
    [
      Fun ("add2", ["a", Type.Int], Type.Int, [
        Return (InfixOper (Plus, Var "a", IntLit 2))
      ]);
      Fun ("main", [], Type.Int, [
        Return (Funcall ("add2", [IntLit 0]))
      ])
    ] in
    ignore prog


let good_ciphersuites =
  String.concat ":"
    [
      "ECDHE-RSA-AES256-SHA384"
    ; "ECDHE-RSA-AES256-GCM-SHA384"
    ; "AES256-SHA256"
    ; "AES128-SHA256"
    ]

Update ciphers used by stunnel/XAPI

let good_ciphersuites =
  String.concat ":"
    [
      "ECDHE-RSA-AES256-GCM-SHA384"
    ; "ECDHE-RSA-AES128-GCM-SHA256"
    ]


open OUnit
open Ctypes

(*
  Call fdopendir() with a bogus file descriptor and check that an exception is raised.
*)
let test_errno_exception_raised () =
  let fdopendir = foreign "fdopendir" (int @-> syscall (ptr void)) in
  assert_raises (Unix.Unix_error(Unix.EBADF, "fdopendir", ""))
    (fun () -> fdopendir (-300))

let suite = "errno tests" >:::
  ["Exception from fdopendir" >:: test_errno_exception_raised;
  ]

let _ =
  run_test_tt_main suite

Test the non-error path in errno-setting calls.

open OUnit
open Ctypes

(*
  Call fdopendir() with a bogus file descriptor and check that an exception is raised.
*)
let test_errno_exception_raised () =
  let fdopendir = foreign "fdopendir" (int @-> syscall (ptr void)) in
  assert_raises (Unix.Unix_error(Unix.EBADF, "fdopendir", ""))
    (fun () -> fdopendir (-300))

(*
  Call chdir() with a valid directory path and check that zero is returned.
*)
let test_int_return_errno_exception_raised () =
  let chdir = foreign "chdir" (string @-> syscall int) in
  assert_raises (Unix.Unix_error(Unix.ENOENT, "chdir", ""))
    (fun () -> chdir "/unlikely_to_exist")

(*
  Call chdir() with a valid directory path and check that zero is returned.
*)
let test_errno_no_exception_raised () =
  let chdir = foreign "chdir" (string @-> syscall int) in
  assert_equal 0 (chdir (Sys.getcwd ()))

let suite = "errno tests" >:::
  ["Exception from fdopendir" >:: test_errno_exception_raised;
   "Exception from chdir" >:: test_int_return_errno_exception_raised;
   "No exception from chdir" >:: test_errno_no_exception_raised;
  ]

let _ =
  run_test_tt_main suite


(** Very small tooling for format printers. *)

include Format

(* Only in the stdlib since 4.02, so we copy. *)
let rec list pp ppf = function
  | [] -> ()
  | [v] -> pp ppf v
  | v :: vs ->
    pp ppf v;
    pp_print_space ppf ();
    list pp ppf vs

let str = pp_print_string
let sexp fmt s pp x = fprintf fmt "@[<3>(%s@ %a)@]" s pp x
let pair pp1 pp2 fmt (v1,v2) =
  pp1 fmt v1; pp_print_space fmt () ; pp2 fmt v2
let triple pp1 pp2 pp3 fmt (v1, v2, v3) =
  pp1 fmt v1; pp_print_space fmt () ;
  pp2 fmt v2; pp_print_space fmt () ;
  pp3 fmt v3
let int = pp_print_int
let optint fmt = function
  | None -> ()
  | Some i -> fprintf fmt "@ %d" i

Add more helpers to Re_fmt

(** Very small tooling for format printers. *)

include Format

type 'a t = Format.formatter -> 'a -> unit

(* Only in the stdlib since 4.02, so we copy. *)
let rec list ?(pp_sep = pp_print_cut) pp ppf = function
  | [] -> ()
  | [v] -> pp ppf v
  | v :: vs ->
    pp ppf v;
    pp_sep ppf ();
    list ~pp_sep pp ppf vs

(* want this name to make sure we don't use pp_print_list from stdlib
   accidentally *)
let pp_print_list = list

let str = pp_print_string
let sexp fmt s pp x = fprintf fmt "@[<3>(%s@ %a)@]" s pp x
let pair pp1 pp2 fmt (v1,v2) =
  pp1 fmt v1; pp_print_space fmt () ; pp2 fmt v2
let triple pp1 pp2 pp3 fmt (v1, v2, v3) =
  pp1 fmt v1; pp_print_space fmt () ;
  pp2 fmt v2; pp_print_space fmt () ;
  pp3 fmt v3
let int = pp_print_int
let optint fmt = function
  | None -> ()
  | Some i -> fprintf fmt "@ %d" i

let quote fmt s = Format.fprintf fmt "\"%s\"" s

let pp_olist pp_elem fmt =
  Format.fprintf fmt "@[<3>[@ %a@ ]@]"
    (pp_print_list
       ~pp_sep:(fun fmt () -> fprintf fmt ";@ ")
       pp_elem)

let pp_str_list = pp_olist quote


(*
 * 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 Core.Std
open Async.Std

open Xcp_service

let version = "0.1"

let _ =
  let () = configure2 ~name:"xapi-script-storage" ~version ~doc:"This allows storage adapters to be implemented as scripts" () in
  ()

Add a 'root' directory, which will contain the adapter directories

(*
 * 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 U = Unix
open Core.Std
open Async.Std

open Xcp_service

let description = String.concat ~sep:" " [
  "Allow xapi storage adapters to be written as individual scripts.";
  "To add a storage adapter, create a sub-directory in the --root directory";
  "with the name of the adapter (e.g. org.xen.xcp.storage.mylvm) and place";
  "the scripts inside.";
]

let root_dir = ref "/var/lib/xapi/storage-scripts"

let resources = [
  { Xcp_service.name = "root";
    description = "directory whose sub-directories contain sets of per-operation scripts, one sub-directory per queue name";
    essential = true;
    path = root_dir;
    perms = [ U.X_OK ];
  }
]

let _ =
  match configure2
    ~name:"xapi-script-storage"
    ~version:Version.version
    ~doc:description
    ~resources
    () with
  | `Ok () -> ()
  | `Error x ->
    Printf.fprintf stderr "Error: %s\n%!" x;
    Pervasives.exit 1


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

(*****************************************************************************)
(* The main entry point *)
(*****************************************************************************)

type options = {
  ai_mode          : Ai_options.prepared option;
  check_mode       : bool;
  json_mode        : bool;
  root             : Path.t;
  should_detach    : bool;
  convert          : Path.t option;
  no_load          : bool;
  save_filename    : string option;
  waiting_client   : Handle.handle option;
}

val parse_options: unit -> options
val default_options: root:string -> options

(*****************************************************************************)
(* Accessors *)
(*****************************************************************************)

val ai_mode             : options -> Ai_options.prepared option
val check_mode          : options -> bool
val json_mode           : options -> bool
val root                : options -> Path.t
val should_detach       : options -> bool
val convert             : options -> Path.t option
val no_load             : options -> bool
val save_filename       : options -> string option
val waiting_client      : options -> Handle.handle option

Make ServerArgs.options an abstract type

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

(*****************************************************************************)
(* The main entry point *)
(*****************************************************************************)

type options

val parse_options: unit -> options
val default_options: root:string -> options

(*****************************************************************************)
(* Accessors *)
(*****************************************************************************)

val ai_mode             : options -> Ai_options.prepared option
val check_mode          : options -> bool
val json_mode           : options -> bool
val root                : options -> Path.t
val should_detach       : options -> bool
val convert             : options -> Path.t option
val no_load             : options -> bool
val save_filename       : options -> string option
val waiting_client      : options -> Handle.handle option


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

open Utils_js

val implementation_file :
  reader:Mutator_state_reader.t -> (Modulename.t -> File_key.t option) Expensive.t

val calc_direct_dependents :
  MultiWorkerLwt.worker list option ->
  candidates:FilenameSet.t ->
  root_files:FilenameSet.t ->
  root_modules:Modulename.Set.t ->
  FilenameSet.t Lwt.t

val calc_dependency_info :
  reader:Mutator_state_reader.t ->
  MultiWorkerLwt.worker list option ->
  parsed:(* workers *)
         FilenameSet.t ->
  Dependency_info.t Lwt.t

val calc_partial_dependency_graph :
  reader:Mutator_state_reader.t ->
  MultiWorkerLwt.worker list option ->
  (* workers *)
  FilenameSet.t ->
  parsed:(* files *)
         FilenameSet.t ->
  Dependency_info.partial_dependency_graph Lwt.t

Remove unused-outside-module function signature from interface

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

open Utils_js

val calc_direct_dependents :
  MultiWorkerLwt.worker list option ->
  candidates:FilenameSet.t ->
  root_files:FilenameSet.t ->
  root_modules:Modulename.Set.t ->
  FilenameSet.t Lwt.t

val calc_dependency_info :
  reader:Mutator_state_reader.t ->
  MultiWorkerLwt.worker list option ->
  parsed:(* workers *)
         FilenameSet.t ->
  Dependency_info.t Lwt.t

val calc_partial_dependency_graph :
  reader:Mutator_state_reader.t ->
  MultiWorkerLwt.worker list option ->
  (* workers *)
  FilenameSet.t ->
  parsed:(* files *)
         FilenameSet.t ->
  Dependency_info.partial_dependency_graph Lwt.t


open Common
open Types
open Printf
open WithM

module List = ListLabels
module G = Global

let (>>=) = Res.(>>=)

let makefile : install_type = object
  method install ~source_dir ~flags ~targets ~patches = begin
    G.create_dirs ();
    Env.write_env ();

    Log.info "Applying patches";
    List.iter patches ~f:(fun p ->
        let abs_p = G.base_dir </> p in
        exec_exn ["patch"; "-p1"; "-i"; abs_p];
        Log.debug "Applied patch %S" p;
    );

    Log.info "Starting Makefile build";
    WithRes.bindres WithRes.with_sys_chdir source_dir & fun _old_path ->
      Env.with_env & fun () ->
        (if Sys.file_exists "configure" then
            let flags =
              if Sys.file_exists "_oasis"
              (* maybe we should always pass --prefix,
                 not only for oasis projects *)
              then
                ["--prefix"; G.dep_dir] @ flags
              else
                flags
            in
            if (Unix.stat "configure").Unix.st_perm land 0o100 <> 0 then
              exec (["./configure"] @ flags)
            else
              exec (["sh" ; "./configure"] @ flags)
         else
            Res.return ()) >>= fun () ->
        let make = getenv ~default:"make" "MAKE" in
        exec (make :: targets) >>= fun () ->
        exec [make; "install"]
  end
end

Apply patches *in* the build dir

open Common
open Types
open Printf
open WithM

module List = ListLabels
module G = Global

let (>>=) = Res.(>>=)

let makefile : install_type = object
  method install ~source_dir ~flags ~targets ~patches = begin
    G.create_dirs ();
    Env.write_env ();

    Log.info "Applying patches";
    WithRes.bindres WithRes.with_sys_chdir source_dir & fun _old_path ->
      List.iter patches ~f:(fun p ->
        let abs_p = G.base_dir </> p in
        exec_exn ["patch"; "-p1"; "-i"; abs_p];
        Log.debug "Applied patch %S" p;
      );

    Log.info "Starting Makefile build";
    WithRes.bindres WithRes.with_sys_chdir source_dir & fun _old_path ->
      Env.with_env & fun () ->
        (if Sys.file_exists "configure" then
            let flags =
              if Sys.file_exists "_oasis"
              (* maybe we should always pass --prefix,
                 not only for oasis projects *)
              then
                ["--prefix"; G.dep_dir] @ flags
              else
                flags
            in
            if (Unix.stat "configure").Unix.st_perm land 0o100 <> 0 then
              exec (["./configure"] @ flags)
            else
              exec (["sh" ; "./configure"] @ flags)
         else
            Res.return ()) >>= fun () ->
        let make = getenv ~default:"make" "MAKE" in
        exec (make :: targets) >>= fun () ->
        exec [make; "install"]
  end
end


(*
 * Copyright 2007 Digirati Informática, Serviços e Telecomunicações
 *
 * This file is distributed under the terms of version 2.1 of the GNU
 * Lesser General Public License. See the LICENSE file for details.
 *)

exception Fd_error of string

let _ = Callback.register_exception "Fd.Fd_error" (Fd_error "")

external send_fd : conn:Unix.file_descr -> fd:Unix.file_descr -> unit =
  "ocaml_send_fd"

external recv_fd : conn:Unix.file_descr -> Unix.file_descr =
  "ocaml_recv_fd"

external fexecve : fd:Unix.file_descr -> args:string array ->
  env:string array -> unit = "ocaml_fexecve"

Fix return type in fexecve signature.

(*
 * Copyright 2007 Digirati Informática, Serviços e Telecomunicações
 *
 * This file is distributed under the terms of version 2.1 of the GNU
 * Lesser General Public License. See the LICENSE file for details.
 *)

exception Fd_error of string

let _ = Callback.register_exception "Fd.Fd_error" (Fd_error "")

external send_fd : conn:Unix.file_descr -> fd:Unix.file_descr -> unit =
  "ocaml_send_fd"

external recv_fd : conn:Unix.file_descr -> Unix.file_descr =
  "ocaml_recv_fd"

external fexecve : fd:Unix.file_descr -> args:string array ->
  env:string array -> 'a = "ocaml_fexecve"


(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the "hack" directory of this source tree.
 *
 *)

type kind =
  | Class
  | Function
  | Method of string * string
  | LocalVar
  | Property of string * string
  | ClassConst of string * string
  | Typeconst of string * string
  | GConst

type 'a t = {
  name:  string;
  type_: kind;
  is_declaration: bool;
  (* Span of the symbol itself *)
  pos: 'a Pos.pos;
}

let to_absolute x = { x with
  pos = Pos.to_absolute x.pos;
}

let kind_to_string = function
  | Class -> "type_id"
  | Method _ -> "method"
  | Function -> "function"
  | LocalVar -> "local"
  | Property _ -> "property"
  | ClassConst _ -> "member_const"
  | Typeconst _ -> "typeconst"
  | GConst -> "global_const"

Make doc block finding fall back to interface for hover.

(**
 * Copyright (c) 2015, Facebook, Inc.
 * All rights reserved.
 *
 * This source code is licensed under the MIT license found in the
 * LICENSE file in the "hack" directory of this source tree.
 *
 *)

type kind =
  | Class
  | Function
  | Method of string * string
  | LocalVar
  | Property of string * string
  | ClassConst of string * string
  | Typeconst of string * string
  | GConst

type 'a t = {
  name:  string;
  type_: kind;
  is_declaration: bool;
  (* Span of the symbol itself *)
  pos: 'a Pos.pos;
}

let to_absolute x = { x with
  pos = Pos.to_absolute x.pos;
}

let kind_to_string = function
  | Class -> "type_id"
  | Method _ -> "method"
  | Function -> "function"
  | LocalVar -> "local"
  | Property _ -> "property"
  | ClassConst _ -> "member_const"
  | Typeconst _ -> "typeconst"
  | GConst -> "global_const"

let enclosing_class occurrence =
  match occurrence.type_ with
  | Method (c, _)
  | Property (c, _)
  | ClassConst (c, _)
  | Typeconst (c, _) -> Some c
  | _ -> None


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

Replace \r (DOS) by \n (Unix) line endings


open OUnit

let all_tests =
  [
    Test_base64.tests;
    Test_unix.tests;
(*    Test_print.tests;
    Test_toplevel.tests; *)
    Test_pmap.tests;
    Test_vect.tests;
    Test_file.tests;
    Test_string.tests;
    Test_substring.tests;
    Test_digest.tests;
    Test_enum.tests;
    Test_set.tests;
  ]

let () =
  print_endline "Running Batteries tests";
  ignore(OUnit.run_test_tt_main ("All" >::: all_tests));

Add failing batDynArray test to testsuite

open OUnit

let all_tests =
  [
    Test_base64.tests;
    Test_unix.tests;
(*    Test_print.tests;
    Test_toplevel.tests; *)
    Test_pmap.tests;
    Test_vect.tests;
    Test_file.tests;
    Test_string.tests;
    Test_substring.tests;
    Test_digest.tests;
    Test_enum.tests;
    Test_set.tests;
    Test_dynarray.tests;
  ]

let () =
  print_endline "Running Batteries tests";
  ignore(OUnit.run_test_tt_main ("All" >::: all_tests));


open Printf
open NSString

(* this tests:
   arg type for pointers
   ret type for string
*)

let ns_of_string (s : string) = new native_NSString (class_NSString#stringWithCString s)
let string_of_ns (ns : NSString.native_NSString) = ns#cStringUsingEncoding 4L

let f2 () =
  Debug.f "create NSCalendarDate";
  let nc = NSCalendarDate.class_NSCalendarDate#calendarDate in
  let c = new NSCalendarDate.native_NSCalendarDate nc in
    Debug.f "making format";
    let format = ((ns_of_string "foo %Y-%m-%d %H:%M:%S %z") :> [`NSString] Objc.t) in
      Debug.f "getting description";
      let ns = c#descriptionWithCalendarFormat format in
	Debug.f "getting back a string";
	let s = (string_of_ns (new native_NSString ns)) in
	  Debug.f "%s" s

let () =
  f2();
  prerr_endline "DONE"

Use symbolic name of enum

open Printf
open NSString

(* this tests:
   arg type for pointers
   ret type for string
*)

let ns_of_string (s : string) = new native_NSString (class_NSString#stringWithCString s)
let string_of_ns (ns : NSString.native_NSString) = ns#cStringUsingEncoding _NSUTF8StringEncoding

let f2 () =
  Debug.f "create NSCalendarDate";
  let nc = NSCalendarDate.class_NSCalendarDate#calendarDate in
  let c = new NSCalendarDate.native_NSCalendarDate nc in
    Debug.f "making format";
    let format = ((ns_of_string "foo %Y-%m-%d %H:%M:%S %z") :> [`NSString] Objc.t) in
      Debug.f "getting description";
      let ns = c#descriptionWithCalendarFormat format in
	Debug.f "getting back a string";
	let s = (string_of_ns (new native_NSString ns)) in
	  Debug.f "%s" s

let () =
  f2();
  prerr_endline "DONE"


(* Functions added in OCaml 4.03 *)

type ('a,'b) result = Ok of 'a | Error of 'b

module String = struct
  include String

  let lowercase_ascii = lowercase
  let capitalize_ascii = capitalize
end

module Unix = struct
  include Unix

  let has_symlink () = not Sys.win32
end

module Sys = struct
  include Sys

  let int_size = word_size - 1
end

Revert "Restore OCaml < 4.03 compatibility"

(* Functions added in OCaml 4.03 *)

module String = struct
  include String

  let lowercase_ascii = lowercase
  let capitalize_ascii = capitalize
end

module Unix = struct
  include Unix

  let has_symlink () = not Sys.win32
end

module Sys = struct
  include Sys

  let int_size = word_size - 1
end


module Infix =
struct
  let (|>) x f = f x

end

Move logging to Utils module

module Infix =
struct
  let (|>) x f = f x

end

let verbose = ref false

(* Logging *)
let log_message format =
  if !verbose then
    Printf.printf format
  else
    Printf.ifprintf stdout format


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

(** Error report. *)

val print_loc : Loc.t -> Pp.std_ppcmds

(** Pre-explain a vernac interpretation error *)

val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn

(** General explain function. Should not be used directly now,
    see instead function [Errors.print] and variants *)

val explain_exn_default : exn -> Pp.std_ppcmds

val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit

Allow catching of EvaluatedError exceptions.

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

(** Toplevel Exception *)
exception EvaluatedError of Pp.std_ppcmds * exn option

(** Error report. *)

val print_loc : Loc.t -> Pp.std_ppcmds

(** Pre-explain a vernac interpretation error *)

val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn

(** General explain function. Should not be used directly now,
    see instead function [Errors.print] and variants *)

val explain_exn_default : exn -> Pp.std_ppcmds

val register_additional_error_info : (Util.iexn -> (Pp.std_ppcmds option * Loc.t) option) -> unit


(* Benchmark File_tree.t's internal cache *)

open Stdune
open Dune

let deep_path = "a1/a2/a3/a4/a5/a6/a7/a8/a9/10"

let setup = lazy (
  let tmp = Path.External.of_string (Filename.get_temp_dir_name ()) in
  Path.External.mkdir_p (Path.External.relative tmp deep_path);
  Path.set_root tmp;
  Path.set_build_dir (Path.Kind.of_string "_build");
  let ft = (Dune_load.load ()).file_tree in
  let path = Path.of_string deep_path in
  at_exit (fun () -> Sys.remove "./dune-project");
  (ft, path))

let%bench_fun "File_tree.find_dir" =
  let (ft, path) = Lazy.force setup in
  fun () ->
    ignore (Sys.opaque_identity (File_tree.find_dir ft path)
            : File_tree.Dir.t option)

Fix file tree cache benchmark building

(* Benchmark File_tree.t's internal cache *)

open Stdune
open Dune

let deep_path = "a1/a2/a3/a4/a5/a6/a7/a8/a9/10"

let setup = lazy (
  let tmp = Path.External.of_string (Filename.get_temp_dir_name ()) in
  Path.External.mkdir_p (Path.External.relative tmp deep_path);
  Path.set_root tmp;
  Path.set_build_dir (Path.Kind.of_string "_build");
  let ft = (Dune_load.load ()).file_tree in
  let path = Path.Source.of_string deep_path in
  at_exit (fun () -> Sys.remove "./dune-project");
  (ft, path))

let%bench_fun "File_tree.find_dir" =
  let (ft, path) = Lazy.force setup in
  fun () ->
    ignore (Sys.opaque_identity (File_tree.find_dir ft path)
            : File_tree.Dir.t option)


include Ls_type

module Stream = Ls_stream

include Ls_engine

include Ls_syntax

type lstream = (string * float array) Stream.Seq.t

module Lstream = Stream.Seq

include Engine(Lstream)

Fix lstream type so it's directly linked with the Lstream module.

include Ls_type

module Stream = Ls_stream

include Ls_engine

include Ls_syntax

module Lstream = Stream.Seq

type lstream = (string * float array) Lstream.t

include Engine(Lstream)


open Printf

let () =
  let arg_length = Array.length Sys.argv in
  if !Sys.interactive then
    ()
  else if arg_length <= 1 then
    print_endline "Please specify IMGT alignments directory."
  else
    let dir = Sys.argv.(1) in
    let num_alt_to_add, fname =
      if arg_length > 2 then
        let n = int_of_string Sys.argv.(2) in
        Some n, sprintf "A_gen_w%d" n
      else
        None, "A_gen_all"
    in
    let f = Filename.concat dir "A_gen.txt" in
    let g = To_graph.construct ?num_alt_to_add (Mas_parser.from_file f) in
    exit (Ref_graph.output ~short:true fname g)

Update test script to take new construct parameters

open Printf

let () =
  let arg_length = Array.length Sys.argv in
  if !Sys.interactive then
    ()
  else if arg_length <= 1 then
    print_endline "Please specify IMGT alignments directory."
  else
    let dir = Sys.argv.(1) in
    let num_alt_to_add, fname =
      if arg_length > 2 then
        let n = int_of_string Sys.argv.(2) in
        Some n, sprintf "A_gen_w%d" n
      else
        None, "A_gen_all"
    in
    let f = Filename.concat dir "A_gen.txt" in
    let g = To_graph.construct ?num_alt_to_add [] (Mas_parser.from_file f) in
    exit (Ref_graph.output ~short:true fname g)


open Util
open Common

let () =
  if !Sys.interactive then () else
    let open MSA in
    let open 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 =
        Segments.distances ~reference:mp.ref_elems ~allele
        |> List.map ~f:(fun d -> sprintf "%d" d.Segments.mismatches)
        |> String.concat ~sep:";"
      in
      printf "ref vs %s: %s\n" al1 ds;
      List.iter mp.alt_elems ~f:(fun (al2, allele2) ->
        let dvs =
          Segments.distances_between ~reference:mp.ref_elems
            ~allele1:allele ~allele2
          |> List.map ~f:(fun d -> sprintf "%d" d.Segments.mismatches)
          |> String.concat ~sep:";"
        in
        printf " %s vs %s: %s\n" al1 al2 dvs))

Split up the debugging messages

open Util
open Common

let () =
  if !Sys.interactive then () else
    let open MSA in
    let open 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) ->
      printf "ref vs %s:%!" al1;
      let ds =
        Segments.distances ~reference:mp.ref_elems ~allele
        |> List.map ~f:(fun d -> sprintf "%d" d.Segments.mismatches)
        |> String.concat ~sep:";"
      in
      printf "%s\n" ds;
      List.iter mp.alt_elems ~f:(fun (al2, allele2) ->
        printf " %s vs %s:" al1 al2;
        let dvs =
          Segments.distances_between ~reference:mp.ref_elems
            ~allele1:allele ~allele2
          |> List.map ~f:(fun d -> sprintf "%d" d.Segments.mismatches)
          |> String.concat ~sep:";"
        in
        printf " %s\n" dvs))


open  Amqp_client_lib

module Channel = Channel
module Connection = Connection
module Exchange = Exchange
module Framing = Framing
module Io = Io
module Message = Message
module Protocol_helpers = Protocol_helpers
module Protocol = Protocol
module Queue = Queue
module Rpc = Rpc
module Types = Types
module Thread = Thread

Remove internal modules from Amqp module

open  Amqp_client_lib

module Channel = Channel
module Connection = Connection
module Exchange = Exchange
module Message = Message
module Queue = Queue
module Rpc = Rpc
module Types = Types


type argument =
  | Int32 of int32
  | Float32 of float
  | Str of string
  | Blob of string

let encode_float f =
  BITSTRING {
    Int32.bits_of_float f : 32 : bigendian
  }

let encode_int i =
  BITSTRING {
    i : 32 : bigendian
  }

let decode_float b =
  bitmatch b with {
    i : 4*8 : bigendian
  } ->
    Int32.float_of_bits i

let decode_int b =
  bitmatch b with {
    i : 4*8 : bigendian
  } -> i

Change semantics of the decoding functions

type argument =
  | Int32 of int32
  | Float32 of float
  | Str of string
  | Blob of string

let encode_float f =
  BITSTRING {
    Int32.bits_of_float f : 32 : bigendian
  }

let encode_int i =
  BITSTRING {
    i : 32 : bigendian
  }

let read_float data =
  bitmatch data with {
    i : 4*8 : bigendian;
    rest : -1 : bitstring
  } ->
    Int32.float_of_bits i, rest

let read_int data =
  bitmatch data with {
    i : 4*8 : bigendian;
    rest : -1 : bitstring
  } -> i, rest


(*
  OCaml HTTP - do it yourself (fully OCaml) HTTP daemon

  Copyright (C) <2002-2005> Stefano Zacchiroli <zack@cs.unibo.it>

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU Library General Public License as
  published by the Free Software Foundation, version 2.

  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 Library General Public License for more details.

  You should have received a copy of the GNU Library General Public
  License along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  USA
*)

(** Constants *)

val default_version: Types.version

val server_string: string

Fix use of Types to Code

(*
  OCaml HTTP - do it yourself (fully OCaml) HTTP daemon

  Copyright (C) <2002-2005> Stefano Zacchiroli <zack@cs.unibo.it>

  This program is free software; you can redistribute it and/or modify
  it under the terms of the GNU Library General Public License as
  published by the Free Software Foundation, version 2.

  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 Library General Public License for more details.

  You should have received a copy of the GNU Library General Public
  License along with this program; if not, write to the Free Software
  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
  USA
*)

(** Constants *)

val default_version: Code.version

val server_string: string


open Lwt.Infix

module Make (Cohttp_client : Cohttp_lwt.S.Client) = struct
  type error = |

  let pp_error : error Fmt.t = fun _ppf -> function _ -> .

  let get ?(headers = []) uri =
    let headers = Cohttp.Header.of_list headers in
    Cohttp_client.get ~headers uri >>= fun (_response, body) ->
    Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body)

  let post ?(headers = []) uri body =
    let headers = Cohttp.Header.of_list headers in
    let body = Cohttp_lwt.Body.of_string body in
    Cohttp_client.post ~headers ~chunked:false ~body uri
    >>= fun (_response, body) ->
    Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body)
end

Handle redirections with CoHTTP (only for git-unix)

open Lwt.Infix

module Make (Cohttp_client : Cohttp_lwt.S.Client) = struct
  type error = |

  let pp_error : error Fmt.t = fun _ppf -> function _ -> .

  let with_redirects ?(max = 10) ~f uri =
    if max < 10 then invalid_arg "with_redirects";
    let tbl = Hashtbl.create 0x10 in
    let rec go max uri =
      f uri >>= fun (resp, body) ->
      let status_code = Cohttp.(Response.status resp |> Code.code_of_status) in
      if Cohttp.Code.is_redirection status_code then
        match Cohttp.(Response.headers resp |> Header.get_location) with
        | Some uri' when Hashtbl.mem tbl uri' || max = 0 ->
            Lwt.return (resp, body)
        | Some uri' ->
            Hashtbl.add tbl uri' ();
            Cohttp_lwt.Body.drain_body body >>= fun () -> go (pred max) uri'
        | None -> Lwt.return (resp, body)
      else Lwt.return (resp, body)
    in
    go max uri

  let get ~ctx:_ ?(headers = []) uri =
    let headers = Cohttp.Header.of_list headers in
    let f uri = Cohttp_client.get ~headers uri in
    with_redirects ~f uri >>= fun (_resp, body) ->
    Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body)

  let post ~ctx:_ ?(headers = []) uri body =
    let headers = Cohttp.Header.of_list headers in
    let body = Cohttp_lwt.Body.of_string body in
    let f uri = Cohttp_client.post ~headers ~chunked:false ~body uri in
    with_redirects ~f uri >>= fun (_resp, body) ->
    Cohttp_lwt.Body.to_string body >>= fun body -> Lwt.return_ok ((), body)
end


(*
 * Copyright (c) 2015 David Sheets <sheets@alum.mit.edu>
 *
 * 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 Ctypes

let () =
  let type_oc = open_out "lib_gen/unix_fcntl_types_detect.c" in
  let fmt = Format.formatter_of_out_channel type_oc in
  Format.fprintf fmt "#define _GNU_SOURCE@.";
  Format.fprintf fmt "#define _POSIX_C_SOURCE 200809L@.";
  Format.fprintf fmt "#define _DARWIN_C_SOURCE@.";
  Format.fprintf fmt "#include <fcntl.h>@.";
  Cstubs.Types.write_c fmt (module Unix_fcntl_types.C);
  close_out type_oc;

Disable feature macros for generated source on FreeBSD

(*
 * Copyright (c) 2015 David Sheets <sheets@alum.mit.edu>
 *
 * 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 Ctypes

let () =
  let type_oc = open_out "lib_gen/unix_fcntl_types_detect.c" in
  let fmt = Format.formatter_of_out_channel type_oc in
  Format.fprintf fmt "#ifndef __FreeBSD__@.";
  Format.fprintf fmt "#  define _GNU_SOURCE@.";
  Format.fprintf fmt "#  define _POSIX_C_SOURCE 200809L@.";
  Format.fprintf fmt "#  define _DARWIN_C_SOURCE@.";
  Format.fprintf fmt "#endif@.";
  Format.fprintf fmt "#include <fcntl.h>@.";
  Cstubs.Types.write_c fmt (module Unix_fcntl_types.C);
  close_out type_oc;


(*
 * 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 Stdext
open Listext
open Threadext
module D = Debug.Make(struct let name="xapi" end)
open D

let mutex = Mutex.create ()
let create ~__context ~uSB_group ~host ~other_config ~path
      ~vendor_id ~vendor_desc ~product_id ~product_desc ~serial ~version ~description =
  let pusb = Ref.make () and uuid = Uuid.make_uuid () in
  let host = Helpers.get_localhost ~__context in
  Mutex.execute mutex (fun () ->
      Db.PUSB.create ~__context ~ref:pusb ~uuid:(Uuid.to_string uuid)
        ~uSB_group ~host ~attached:Ref.null ~other_config ~path ~vendor_id ~vendor_desc ~product_id
         ~product_desc ~serial ~version ~description ~passthrough_enabled:false;
  );
  debug "PUSB ref='%s' created" (Ref.string_of pusb);
  pusb

let scan ~__context =
  debug "pusb scan to do"

Remove mutex on pusb create

(*
 * 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 Stdext
open Listext
open Threadext
module D = Debug.Make(struct let name="xapi" end)
open D

let mutex = Mutex.create ()
let create ~__context ~uSB_group ~host ~other_config ~path
      ~vendor_id ~vendor_desc ~product_id ~product_desc ~serial ~version ~description =
  let pusb = Ref.make () and uuid = Uuid.make_uuid () in
  let host = Helpers.get_localhost ~__context in
  Db.PUSB.create ~__context ~ref:pusb ~uuid:(Uuid.to_string uuid)
    ~uSB_group ~host ~attached:Ref.null ~other_config ~path ~vendor_id ~vendor_desc ~product_id
    ~product_desc ~serial ~version ~description ~passthrough_enabled:false;
  debug "PUSB ref='%s' created" (Ref.string_of pusb);
  pusb

let scan ~__context =
  debug "pusb scan to do"