OCaml code modernization

ocaml/Command_line.ml

@@ -1,3 +1,5 @@
+exception Error of string
+
 type short_opt     = char
 type long_opt      = string 
 type optional      = Mandatory | Optional 
@@ -181,15 +183,16 @@ let set_specs specs_in =
     Getopt.parse_cmdline cmd_specs (fun x -> anon_args := !anon_args @ [x]);
 
     if show_help () then
-        (help () ; exit 0);
+        help ()
-
+    else
         (* Check that all mandatory arguments are set *)
         List.filter (fun x -> x.short <> ' ' && x.opt = Mandatory) !specs
         |> List.iter (fun x -> 
             match get x.long with
             | Some _ -> ()
-        | None -> failwith ("Error: --"^x.long^" option is missing.")
+            | None -> raise (Error ("--"^x.long^" option is missing."))
             )
+
 ;;
 
 

ocaml/Command_line.mli

@@ -59,6 +59,8 @@ let () =
 *)
 
 
+exception Error of string
+
 type short_opt = char
 
 type long_opt = string

ocaml/Makefile

@@ -29,7 +29,7 @@ tests: $(ALL_TESTS)
 .gitignore: $(MLFILES) $(MLIFILES)
 	@for i in .gitignore ezfio.ml element_create_db Qptypes.ml Git.ml *.byte *.native _build $(ALL_EXE) $(ALL_TESTS) \
 	$(patsubst %.ml,%,$(wildcard test_*.ml)) $(patsubst %.ml,%,$(wildcard qp_*.ml)) \
-	$(shell grep Input Input_auto_generated.ml | awk '{print $$2 ".ml"}') \
+	Input_*.ml \
 	qp_edit.ml qp_edit qp_edit.native Input_auto_generated.ml;\
 	do \
 	   echo $$i ; \

ocaml/Message.ml

@@ -63,11 +63,11 @@ end
 
 module Connect_msg : sig
   type t = Tcp | Inproc | Ipc
-  val create : typ:string -> t
+  val create : string -> t
   val to_string : t -> string
 end = struct
   type t = Tcp | Inproc | Ipc
-  let create ~typ =
+  let create typ =
     match typ with
     | "tcp" -> Tcp
     | "inproc" -> Inproc
@@ -515,9 +515,9 @@ let of_string s =
     | Connect_ socket ->
         Connect (Connect_msg.create socket)
     | NewJob_ { state ; push_address_tcp ; push_address_inproc } ->
-        Newjob (Newjob_msg.create push_address_tcp push_address_inproc state)
+        Newjob (Newjob_msg.create ~address_tcp:push_address_tcp ~address_inproc:push_address_inproc ~state)
     | EndJob_ state  ->
-        Endjob (Endjob_msg.create state)
+        Endjob (Endjob_msg.create ~state)
     | GetData_ { state ; client_id ; key } ->
         GetData (GetData_msg.create ~client_id ~state ~key)
     | PutData_ { state ; client_id ; key } ->

ocaml/Molecule.ml

@@ -101,7 +101,7 @@ let to_string_general ~f m =
   |> String.concat "\n"
 
 let to_string =
-  to_string_general ~f:(fun x -> Atom.to_string Units.Angstrom x)
+  to_string_general ~f:(fun x -> Atom.to_string ~units:Units.Angstrom x)
 
 let to_xyz =
   to_string_general ~f:Atom.to_xyz
@@ -113,7 +113,7 @@ let of_xyz_string
     s =
   let l = String_ext.split s ~on:'\n'
        |> List.filter (fun x -> x <> "")
-       |> list_map (fun x -> Atom.of_string units x)
+       |> list_map (fun x -> Atom.of_string ~units x)
   in
   let ne = ( get_charge {
         nuclei=l ;

ocaml/Progress_bar.ml

@@ -10,7 +10,7 @@ type t =
   next       : float;
 }
 
-let init ?(bar_length=20) ?(start_value=0.) ?(end_value=1.) ~title =
+let init ?(bar_length=20) ?(start_value=0.) ?(end_value=1.) title =
   { title ; start_value ; end_value ; bar_length ; cur_value=start_value ;
     init_time= Unix.time () ; dirty = false ; next = Unix.time () }
 

ocaml/Qputils.ml

@@ -56,3 +56,7 @@ let string_of_string s = s
 let list_map f l =
   List.rev_map f l
   |> List.rev
+
+let socket_convert socket =
+    ((Obj.magic (Obj.repr socket)) : [ `Xsub ] Zmq.Socket.t )
+

ocaml/TaskServer.ml

@@ -155,7 +155,7 @@ let new_job msg program_state rep_socket pair_socket =
           ~start_value:0.
           ~end_value:1.
           ~bar_length:20
-          ~title:(Message.State.to_string state)
+          (Message.State.to_string state)
     in
 
     let result =
@@ -776,7 +776,7 @@ let run ~port =
       Zmq.Socket.create zmq_context Zmq.Socket.rep
     in
     Zmq.Socket.set_linger_period rep_socket 1_000_000;
-    bind_socket "REP" rep_socket port;
+    bind_socket ~socket_type:"REP" ~socket:rep_socket ~port;
 
     let initial_program_state =
     {   queue = Queuing_system.create () ;

ocaml/qp_create_ezfio.ml

@@ -677,6 +677,7 @@ let run ?o b au c d m p cart xyz_file =
 
 let () =
 
+  try (
 
   let open Command_line in
   begin
@@ -734,7 +735,7 @@ If a file with the same name as the basis set exists, this file will be read.  O
 
   let basis =
     match Command_line.get "basis" with
-    | None -> assert false
+    | None -> ""
     | Some x -> x
   in
 
@@ -773,10 +774,14 @@ If a file with the same name as the basis set exists, this file will be read.  O
 
   let xyz_filename =
     match Command_line.anon_args () with
-    | [x] -> x
+    | []  -> failwith "input file is missing"
-    | _ -> (Command_line.help () ; failwith "input file is missing")
+    | x::_ -> x
   in
 
   run ?o:output basis au charge dummy multiplicity pseudo cart xyz_filename
+  )
+  with
+  | Failure txt  -> Printf.eprintf "Fatal error: %s\n%!" txt
+  | Command_line.Error txt  -> Printf.eprintf "Command line error: %s\n%!" txt
 
 

ocaml/qp_run.ml

@@ -110,7 +110,7 @@ let run slave ?prefix exe ezfio_file =
   let task_thread =
      let thread =
       Thread.create ( fun () ->
-         TaskServer.run port_number )
+         TaskServer.run ~port:port_number )
      in
      thread ();
   in
@@ -155,6 +155,7 @@ let run slave ?prefix exe ezfio_file =
   in
   Printf.printf "Wall time: %d:%2.2d:%2.2d" (d*24+h) m s ;
   Printf.printf "\n\n";
+  Unix.sleep 1;
   if (exit_code <> 0) then
     exit exit_code
 

ocaml/qp_tunnel.ml

@@ -131,37 +131,64 @@ let () =
   Sys.set_signal  Sys.sigint   handler;
 
 
-  let new_thread req_or_sub addr_in addr_out =
+  let new_thread_req addr_in addr_out =
     let socket_in, socket_out =
-      match req_or_sub with
-      | REQ ->
           create_socket  Zmq.Socket.router  Zmq.Socket.bind     addr_in,
           create_socket  Zmq.Socket.dealer  Zmq.Socket.connect  addr_out
-      | SUB ->
+    in
+
+
+    let action_in =
+        fun () -> Zmq.Socket.recv_all  socket_in  |> Zmq.Socket.send_all  socket_out
+    in
+
+    let action_out =
+        fun () -> Zmq.Socket.recv_all  socket_out |> Zmq.Socket.send_all  socket_in
+    in
+
+    let pollitem =
+      Zmq.Poll.mask_of
+        [| (socket_convert socket_in,  Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |]
+    in
+
+    while !run_status do
+
+        let polling =
+          Zmq.Poll.poll  ~timeout:1000  pollitem
+        in
+
+        match polling with
+          | [| Some Zmq.Poll.In ; Some Zmq.Poll.In |]     -> ( action_out () ; action_in () )
+          | [| _                ; Some Zmq.Poll.In |]     ->   action_out ()
+          | [| Some Zmq.Poll.In ; _                |]     ->   action_in  ()
+          | _                    -> ()
+    done;
+
+    Zmq.Socket.close  socket_in;
+    Zmq.Socket.close  socket_out;
+  in
+
+  let new_thread_sub addr_in addr_out =
+    let socket_in, socket_out =
           create_socket  Zmq.Socket.sub  Zmq.Socket.connect  addr_in,
           create_socket  Zmq.Socket.pub  Zmq.Socket.bind     addr_out
     in
 
-    if req_or_sub = SUB then
     Zmq.Socket.subscribe  socket_in  "";
 
 
 
    let action_in =
-      match req_or_sub with
+        fun () -> Zmq.Socket.recv_all  socket_in  |> Zmq.Socket.send_all  socket_out
-        | REQ -> (fun () -> Zmq.Socket.recv_all  socket_in  |> Zmq.Socket.send_all  socket_out)
-        | SUB -> (fun () -> Zmq.Socket.recv_all  socket_in  |> Zmq.Socket.send_all  socket_out)
     in
 
     let action_out =
-      match req_or_sub with
+        fun () -> ()
-        | REQ -> (fun () -> Zmq.Socket.recv_all  socket_out |> Zmq.Socket.send_all  socket_in )
-        | SUB -> (fun () -> () )
     in
 
     let pollitem =
       Zmq.Poll.mask_of
-        [| (socket_in,  Zmq.Poll.In) ; (socket_out, Zmq.Poll.In) |]
+        [| (socket_convert socket_in,  Zmq.Poll.In) ; (socket_convert socket_out, Zmq.Poll.In) |]
     in
 
 
@@ -194,7 +221,7 @@ let () =
     in
 
     let f () =
-      new_thread  REQ  addr_in  addr_out
+      new_thread_req  addr_in  addr_out
     in
 
     (Thread.create f) ()
@@ -212,7 +239,7 @@ let () =
     in
 
     let f () =
-      new_thread  REQ  addr_in  addr_out
+      new_thread_req  addr_in  addr_out
     in
     (Thread.create f) ()
   in
@@ -228,7 +255,7 @@ let () =
     in
 
     let f () =
-      new_thread  SUB  addr_in  addr_out
+      new_thread_sub  addr_in  addr_out
     in
     (Thread.create f) ()
   in
@@ -417,5 +444,3 @@ Or from this host connect to clients using:
   Printf.printf "qp_tunnel exited properly.\n"
 
 
-
-