Index: trunk/omega/src/run_fortran_unit.sh =================================================================== --- trunk/omega/src/run_fortran_unit.sh (revision 8272) +++ trunk/omega/src/run_fortran_unit.sh (revision 8273) @@ -1,46 +1,45 @@ #! /bin/sh ######################################################################## # This script is for developers only and needs not to be portable. # This script assumes an opam installation with many versions of # O'Caml available as switches. ######################################################################## # tl;dr : don't try this at home, kids ;) ######################################################################## src=$(dirname $(realpath $0)) tmp=$(mktemp -d) trap "rm -fr $tmp" 0 1 2 3 15 cd $tmp || exit 2 cp -a \ $src/fortran_unit.ml \ $src/format_Fortran.mli $src/format_Fortran*.ml \ $src/OUnit.mli $src/OUnit.ml \ . compile_and_run () { switch=$1 tag=$2 flags="-w -D $3" opam switch $switch >/dev/null || exit 2 opam switch show eval $(opam env) rm -f fortran_unit *.o *.cm[iox] ocamlopt OUnit.mli format_Fortran.mli ocamlopt $flags -o fortran_unit -I $src unix.cmxa \ OUnit.ml format_Fortran$tag.ml fortran_unit.ml ./fortran_unit # -verbose } ### Here we will loop over compiler/library versions -compile_and_run 3.12.0 "" -compile_and_run 4.01.0 "" -compile_and_run 4.02.3 "" -compile_and_run 4.03.0 "" -compile_and_run 4.05.0 "" -compile_and_run 4.06.1 "" -unsafe-string -compile_and_run 4.07.1 "" -unsafe-string +compile_and_run 4.02.3 "" -safe-string +compile_and_run 4.03.0 "" -safe-string +compile_and_run 4.05.0 "" -safe-string +compile_and_run 4.06.1 "" -safe-string +compile_and_run 4.07.1 "" -safe-string +compile_and_run 4.08.0 "" -safe-string exit 0 Index: trunk/omega/src/Makefile.ocaml =================================================================== --- trunk/omega/src/Makefile.ocaml (revision 8272) +++ trunk/omega/src/Makefile.ocaml (revision 8273) @@ -1,77 +1,77 @@ # Makefile.ocaml -- O'Caml rules for O'Mega Makefiles ## ## Process Makefile.am with automake to include this file in Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## -OCAMLC += $(DBG) +OCAMLC += $(DBG) -safe-string OCAMLCI = $(OCAMLC) OCAMLDEBUGFLAGS = -g -OCAMLOPTFLAGS = -inline 64 $(GPROF) +OCAMLOPTFLAGS = -inline 64 $(GPROF) -safe-string OCAML_NATIVE_EXT = .opt OCAML_BYTECODE_EXT = .bin ######################################################################## SUFFIXES = .mll .mly .ml .mli .cmi .cmo .cmx .bin .opt .cmx$(OCAML_NATIVE_EXT): @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ \ unix.cmxa $(OMEGA_CMXA) $< .cmo$(OCAML_BYTECODE_EXT): @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLDEBUGFLAGS) $(OCAMLFLAGS) -o $@ \ unix.cma $(OMEGA_CMA) $< .ml.cmx: @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ -c $< .mli.cmi: @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLCI) $(OCAMLFLAGS) -o $@ -c $< .ml.cmo: @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLDEBUGFLAGS) $(OCAMLFLAGS) -o $@ -c $< .mll.ml: @if $(AM_V_P); then :; else echo " OCAMLLEX " $@; fi $(AM_V_at)$(OCAMLLEX) -o $@ $< .mly.mli: @if $(AM_V_P); then :; else echo " OCAMLYACC" $@; fi $(AM_V_at)$(OCAMLYACC) -b$* $< .mly.ml: @if $(AM_V_P); then :; else echo " OCAMLYACC" $@; fi $(AM_V_at)$(OCAMLYACC) -b$* $< ######################################################################## ## The End. ######################################################################## Index: trunk/omega/src/OUnit.ml =================================================================== --- trunk/omega/src/OUnit.ml (revision 8272) +++ trunk/omega/src/OUnit.ml (revision 8273) @@ -1,805 +1,805 @@ (* oUnit.ml -- *) (***********************************************************************) (* The OUnit library *) (* *) (* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) (* Copyright (C) 2010 OCamlCore SARL *) (* *) (***********************************************************************) (* Version 1.1.2, with minor modifications by Thorsten Ohl *) (************************************************************************ The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the OUnit software ("the Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. The Software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall Maas-Maarten Zeeman be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. ************************************************************************) open Format (* TODO: really use Format in printf call. Most of the time, not * cuts/spaces/boxes are used *) let global_verbose = ref false let buff_printf f = let buff = Buffer.create 13 in let fmt = formatter_of_buffer buff in f fmt; pp_print_flush fmt (); Buffer.contents buff let bracket set_up f tear_down () = let fixture = set_up () in let () = try let () = f fixture in tear_down fixture with e -> let () = tear_down fixture in raise e in () let bracket_tmpfile ?(prefix="ounit-") ?(suffix=".txt") ?mode f = bracket (fun () -> Filename.open_temp_file ?mode prefix suffix) f (fun (fn, chn) -> begin try close_out chn with _ -> () end; begin try Sys.remove fn with _ -> () end) exception Skip of string let skip_if b msg = if b then raise (Skip msg) exception Todo of string let todo msg = raise (Todo msg) let assert_failure msg = failwith ("OUnit: " ^ msg) let assert_bool msg b = if not b then assert_failure msg let assert_string str = if not (str = "") then assert_failure str let assert_equal ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual = let get_error_string () = (* let max_len = pp_get_margin fmt () in *) (* let ellipsis_text = "[...]" in *) let print_ellipsis p fmt s = (* TODO: find a way to do this let res = p s in let len = String.length res in if diff <> None && len > max_len then begin let len_with_ellipsis = (max_len - (String.length ellipsis_text)) / 2 in (* TODO: we should use %a here to print values *) fprintf fmt "@[%s[...]%s@]" (String.sub res 0 len_with_ellipsis) (String.sub res (len - len_with_ellipsis) len_with_ellipsis) end else begin (* TODO: we should use %a here to print values *) fprintf fmt "@[%s@]" res end *) pp_print_string fmt (p s) in let res = buff_printf (fun fmt -> pp_open_vbox fmt 0; begin match msg with | Some s -> pp_open_box fmt 0; pp_print_string fmt s; pp_close_box fmt (); pp_print_cut fmt () | None -> () end; begin match printer with | Some p -> let p_ellipsis = print_ellipsis p in fprintf fmt "@[expected: @[%a@]@ but got: @[%a@]@]@," p_ellipsis expected p_ellipsis actual | None -> fprintf fmt "@[not equal@]@," end; begin match pp_diff with | Some d -> fprintf fmt "@[differences: %a@]@," d (expected, actual) | None -> () end; pp_close_box fmt ()) in let len = String.length res in if len > 0 && res.[len - 1] = '\n' then String.sub res 0 (len - 1) else res in if not (cmp expected actual) then assert_failure (get_error_string ()) let assert_command ?(exit_code=Unix.WEXITED 0) ?(sinput=Stream.of_list []) ?(foutput=ignore) ?(use_stderr=true) ?env ?verbose prg args = let verbose = match verbose with | Some v -> v | None -> !global_verbose in bracket_tmpfile (fun (fn_out, chn_out) -> let cmd_print fmt = let () = match env with | Some e -> begin pp_print_string fmt "env"; Array.iter (fprintf fmt "@ %s") e; pp_print_space fmt () end | None -> () in pp_print_string fmt prg; List.iter (fprintf fmt "@ %s") args in (* Start the process *) let in_write = Unix.dup (Unix.descr_of_out_channel chn_out) in let (out_read, out_write) = Unix.pipe () in let err = if use_stderr then in_write else Unix.stderr in let args = Array.of_list (prg :: args) in let pid = Unix.set_close_on_exec out_write; if verbose then printf "@[Starting command '%t'@]\n" cmd_print; match env with | Some e -> Unix.create_process_env prg args e out_read in_write err | None -> Unix.create_process prg args out_read in_write err in let () = Unix.close out_read; Unix.close in_write in let () = (* Dump sinput into the process stdin *) - let buff = " " in + let buff = Bytes.make 1 ' ' in Stream.iter (fun c -> let _i : int = - buff.[0] <- c; + Bytes.set buff 0 c; Unix.write out_write buff 0 1 in ()) sinput; Unix.close out_write in let _, real_exit_code = let rec wait_intr () = try Unix.waitpid [] pid with Unix.Unix_error (Unix.EINTR, _, _) -> wait_intr () in wait_intr () in let exit_code_printer = function | Unix.WEXITED n -> Printf.sprintf "exit code %d" n | Unix.WSTOPPED n -> Printf.sprintf "stopped by signal %d" n | Unix.WSIGNALED n -> Printf.sprintf "killed by signal %d" n in (* Dump process output to stderr *) if verbose then begin let chn = open_in fn_out in - let buff = String.make 4096 'X' in + let buff = Bytes.make 4096 'X' in let len = ref (-1) in while !len <> 0 do - len := input chn buff 0 (String.length buff); - printf "%s" (String.sub buff 0 !len); + len := input chn buff 0 (Bytes.length buff); + printf "%s" (Bytes.sub_string buff 0 !len); done; printf "@?"; close_in chn end; (* Check process status *) assert_equal ~msg:(buff_printf (fun fmt -> fprintf fmt "@[Exit status of command '%t'@]" cmd_print)) ~printer:exit_code_printer exit_code real_exit_code; begin let chn = open_in fn_out in try foutput (Stream.of_channel chn) with e -> close_in chn; raise e end) () let raises f = try f (); None with e -> Some e let assert_raises ?msg exn (f: unit -> 'a) = let pexn = Printexc.to_string in let get_error_string () = let str = Format.sprintf "expected exception %s, but no exception was raised." (pexn exn) in match msg with | None -> assert_failure str | Some s -> assert_failure (Format.sprintf "%s\n%s" s str) in match raises f with | None -> assert_failure (get_error_string ()) | Some e -> assert_equal ?msg ~printer:pexn exn e (* Compare floats up to a given relative error *) let cmp_float ?(epsilon = 0.00001) a b = abs_float (a -. b) <= epsilon *. (abs_float a) || abs_float (a -. b) <= epsilon *. (abs_float b) (* Now some handy shorthands *) let (@?) = assert_bool (* The type of test function *) type test_fun = unit -> unit (* The type of tests *) type test = | TestCase of test_fun | TestList of test list | TestLabel of string * test (* Some shorthands which allows easy test construction *) let (>:) s t = TestLabel(s, t) (* infix *) let (>::) s f = TestLabel(s, TestCase(f)) (* infix *) let (>:::) s l = TestLabel(s, TestList(l)) (* infix *) (* Utility function to manipulate test *) let rec test_decorate g = function | TestCase f -> TestCase (g f) | TestList tst_lst -> TestList (List.map (test_decorate g) tst_lst) | TestLabel (str, tst) -> TestLabel (str, test_decorate g tst) (* Return the number of available tests *) let rec test_case_count = function | TestCase _ -> 1 | TestLabel (_, t) -> test_case_count t | TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l type node = | ListItem of int | Label of string type path = node list let string_of_node = function | ListItem n -> string_of_int n | Label s -> s let string_of_path path = String.concat ":" (List.rev_map string_of_node path) (* Some helper function, they are generally applicable *) (* Applies function f in turn to each element in list. Function f takes one element, and integer indicating its location in the list *) let mapi f l = let rec rmapi cnt l = match l with | [] -> [] | h :: t -> (f h cnt) :: (rmapi (cnt + 1) t) in rmapi 0 l let fold_lefti f accu l = let rec rfold_lefti cnt accup l = match l with | [] -> accup | h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t in rfold_lefti 0 accu l (* Returns all possible paths in the test. The order is from test case to root *) let test_case_paths test = let rec tcps path test = match test with | TestCase _ -> [path] | TestList tests -> List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests) | TestLabel (l, t) -> tcps ((Label l)::path) t in tcps [] test (* Test filtering with their path *) module SetTestPath = Set.Make(String) let test_filter ?(skip=false) only test = let set_test = List.fold_left (fun st str -> SetTestPath.add str st) SetTestPath.empty only in let rec filter_test path tst = if SetTestPath.mem (string_of_path path) set_test then begin Some tst end else begin match tst with | TestCase f -> begin if skip then Some (TestCase (fun () -> skip_if true "Test disabled"; f ())) else None end | TestList tst_lst -> begin let ntst_lst = fold_lefti (fun ntst_lst tst i -> let nntst_lst = match filter_test ((ListItem i) :: path) tst with | Some tst -> tst :: ntst_lst | None -> ntst_lst in nntst_lst) [] tst_lst in if not skip && ntst_lst = [] then None else Some (TestList (List.rev ntst_lst)) end | TestLabel (lbl, tst) -> begin let ntst_opt = filter_test ((Label lbl) :: path) tst in match ntst_opt with | Some ntst -> Some (TestLabel (lbl, ntst)) | None -> if skip then Some (TestLabel (lbl, tst)) else None end end in filter_test [] test (* The possible test results *) type test_result = | RSuccess of path | RFailure of path * string | RError of path * string | RSkip of path * string | RTodo of path * string let is_success = function | RSuccess _ -> true | RFailure _ | RError _ | RSkip _ | RTodo _ -> false let is_failure = function | RFailure _ -> true | RSuccess _ | RError _ | RSkip _ | RTodo _ -> false let is_error = function | RError _ -> true | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false let is_skip = function | RSkip _ -> true | RSuccess _ | RFailure _ | RError _ | RTodo _ -> false let is_todo = function | RTodo _ -> true | RSuccess _ | RFailure _ | RError _ | RSkip _ -> false let result_flavour = function | RError _ -> "Error" | RFailure _ -> "Failure" | RSuccess _ -> "Success" | RSkip _ -> "Skip" | RTodo _ -> "Todo" let result_path = function | RSuccess path | RError (path, _) | RFailure (path, _) | RSkip (path, _) | RTodo (path, _) -> path let result_msg = function | RSuccess _ -> "Success" | RError (_, msg) | RFailure (_, msg) | RSkip (_, msg) | RTodo (_, msg) -> msg (* Returns true if the result list contains successes only *) let rec was_successful = function | [] -> true | RSuccess _::t | RSkip _::t -> was_successful t | RFailure _::_ | RError _::_ | RTodo _::_ -> false (* Events which can happen during testing *) type test_event = | EStart of path | EEnd of path | EResult of test_result let maybe_backtrace () = if Printexc.backtrace_status () then "\n" ^ Printexc.get_backtrace () else "" (* Run all tests, report starts, errors, failures, and return the results *) let perform_test report test = let run_test_case f path = try f (); RSuccess path with | Failure s -> RFailure (path, s ^ maybe_backtrace ()) | Skip s -> RSkip (path, s) | Todo s -> RTodo (path, s) | s -> RError (path, Printexc.to_string s ^ maybe_backtrace ()) in let rec run_test path results = function | TestCase(f) -> begin let result = report (EStart path); run_test_case f path in report (EResult result); report (EEnd path); result::results end | TestList (tests) -> begin fold_lefti (fun results t cnt -> run_test ((ListItem cnt)::path) results t) results tests end | TestLabel (label, t) -> begin run_test ((Label label)::path) results t end in run_test [] [] test (* Function which runs the given function and returns the running time of the function, and the original result in a tuple *) let time_fun f x y = let begin_time = Unix.gettimeofday () in (Unix.gettimeofday () -. begin_time, f x y) (* A simple (currently too simple) text based test runner *) let run_test_tt ?verbose test = let verbose = match verbose with | Some v -> v | None -> !global_verbose in let printf = Format.printf in let separator1 = String.make (get_margin ()) '=' in let separator2 = String.make (get_margin ()) '-' in let string_of_result = function | RSuccess _ -> if verbose then "ok\n" else "." | RFailure (_, _) -> if verbose then "FAIL\n" else "F" | RError (_, _) -> if verbose then "ERROR\n" else "E" | RSkip (_, _) -> if verbose then "SKIP\n" else "S" | RTodo (_, _) -> if verbose then "TODO\n" else "T" in let report_event = function | EStart p -> if verbose then printf "%s ...\n" (string_of_path p) | EEnd _ -> () | EResult result -> printf "%s@?" (string_of_result result) in let print_result_list results = List.iter (fun result -> printf "%s\n%s: %s\n\n%s\n%s\n" separator1 (result_flavour result) (string_of_path (result_path result)) (result_msg result) separator2) results in (* Now start the test *) let running_time, results = time_fun perform_test report_event test in let errors = List.filter is_error results in let failures = List.filter is_failure results in let skips = List.filter is_skip results in let todos = List.filter is_todo results in if not verbose then printf "\n"; (* Print test report *) print_result_list errors; print_result_list failures; printf "Ran: %d tests in: %.2f seconds.\n" (List.length results) running_time; (* Print final verdict *) if was_successful results then ( if skips = [] then printf "OK" else printf "OK: Cases: %d Skip: %d\n" (test_case_count test) (List.length skips) ) else printf "FAILED: Cases: %d Tried: %d Errors: %d \ Failures: %d Skip:%d Todo:%d\n" (test_case_count test) (List.length results) (List.length errors) (List.length failures) (List.length skips) (List.length todos); (* Return the results possibly for further processing *) results (* Call this one from you test suites *) let run_test_tt_main ?(arg_specs=[]) ?(set_verbose=ignore) suite = let only_test = ref [] in let () = Arg.parse (Arg.align [ "-verbose", Arg.Set global_verbose, " Run the test in verbose mode."; "-only-test", Arg.String (fun str -> only_test := str :: !only_test), "path Run only the selected test"; "-list-test", Arg.Unit (fun () -> List.iter (fun pth -> print_endline (string_of_path pth)) (test_case_paths suite); exit 0), " List tests"; ] @ arg_specs ) (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) ("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*") in let nsuite = if !only_test = [] then suite else begin match test_filter ~skip:true !only_test suite with | Some test -> test | None -> failwith ("Filtering test "^ (String.concat ", " !only_test)^ " lead to no test") end in let result = set_verbose !global_verbose; run_test_tt ~verbose:!global_verbose nsuite in if not (was_successful result) then exit 1 else result Index: trunk/circe2/src/Makefile.ocaml =================================================================== --- trunk/circe2/src/Makefile.ocaml (revision 8272) +++ trunk/circe2/src/Makefile.ocaml (revision 8273) @@ -1,77 +1,77 @@ # Makefile.ocaml -- O'Caml rules for Circe2 Makefiles ## ## Process Makefile.am with automake to include this file in Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD 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 General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## -OCAMLC += $(DBG) +OCAMLC += $(DBG) -safe-string OCAMLCI = $(OCAMLC) OCAMLDEBUGFLAGS = -g -OCAMLOPTFLAGS = -inline 64 $(GPROF) +OCAMLOPTFLAGS = -inline 64 $(GPROF) -safe-string OCAML_NATIVE_EXT = .opt OCAML_BYTECODE_EXT = .bin ######################################################################## SUFFIXES = .mll .mly .ml .mli .cmi .cmo .cmx .bin .opt .cmx$(OCAML_NATIVE_EXT): @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ \ unix.cmxa bigarray.cmxa $(CIRCE2_CMX) $< .cmo$(OCAML_BYTECODE_EXT): @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLDEBUGFLAGS) $(OCAMLFLAGS) -o $@ \ unix.cma $(CIRCE2_CMO) $< .ml.cmx: @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ -c $< .mli.cmi: @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLCI) $(OCAMLFLAGS) -o $@ -c $< .ml.cmo: @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLDEBUGFLAGS) $(OCAMLFLAGS) -o $@ -c $< .mll.ml: @if $(AM_V_P); then :; else echo " OCAMLLEX " $@; fi $(AM_V_at)$(OCAMLLEX) -o $@ $< .mly.mli: @if $(AM_V_P); then :; else echo " OCAMLYACC" $@; fi $(AM_V_at)$(OCAMLYACC) -b$* $< .mly.ml: @if $(AM_V_P); then :; else echo " OCAMLYACC" $@; fi $(AM_V_at)$(OCAMLYACC) -b$* $< ######################################################################## ## The End. ######################################################################## Index: trunk/circe2/src/float.ml =================================================================== --- trunk/circe2/src/float.ml (revision 8272) +++ trunk/circe2/src/float.ml (revision 8273) @@ -1,134 +1,134 @@ (* circe2/float.ml -- *) (* Copyright (C) 2001-2019 by Thorsten Ohl Circe2 is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Circe2 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open Printf module type T = sig type t (* Difference between~$1.0$ and the minimum float greater than~$1.0$ *) val epsilon : t val to_string : t -> string val input_binary_float : in_channel -> float val input_binary_floats : in_channel -> float array -> unit end module Double = struct type t = float (* Difference between~$1.0$ and the minimum float greater than~$1.0$ \begin{dubious} This is the hard coded value for double precision on Linux/Intel. We should determine this \emph{machine dependent} value during configuration. \end{dubious} *) let epsilon = 2.2204460492503131e-16 let little_endian = true let to_string x = - let s = sprintf "%.17E" x in - for i = 0 to String.length s - 1 do - let c = s.[i] in + let s = Bytes.of_string (sprintf "%.17E" x) in + for i = 0 to Bytes.length s - 1 do + let c = Bytes.get s i in if c = 'e' || c = 'E' then - s.[i] <- 'D' + Bytes.set s i 'D' done; - s + Bytes.to_string s (* Identity floatingpoint numbers that are indistinguishable from integers for more concise printing. *) type int_or_float = | Int of int | Float of float let float_min_int = float min_int let float_max_int = float max_int let soft_truncate x = let eps = 2.0 *. abs_float x *. epsilon in if x >= 0.0 then begin if x > float_max_int then Float x else if x -. floor x <= eps then Int (int_of_float x) else if ceil x -. x <= eps then Int (int_of_float x + 1) else Float x end else begin if x < float_min_int then Float x else if ceil x -. x <= eps then Int (int_of_float x) else if x -. floor x <= eps then Int (int_of_float x - 1) else Float x end let to_short_string x = match soft_truncate x with | Int i -> string_of_int i ^ "D0" | Float x -> to_string x (* Suggested by Xavier Leroy: *) let output_float_big_endian oc f = let n = ref (Int64.bits_of_float f) in for i = 0 to 7 do output_byte oc (Int64.to_int (Int64.shift_right_logical !n 56)); n := Int64.shift_left !n 8 done let output_float_little_endian oc f = let n = ref (Int64.bits_of_float f) in for i = 0 to 7 do output_byte oc (Int64.to_int !n); n := Int64.shift_right_logical !n 8 done let input_float_big_endian ic = let n = ref Int64.zero in for i = 0 to 7 do let b = input_byte ic in n := Int64.logor (Int64.shift_left !n 8) (Int64.of_int b) done; Int64.float_of_bits !n let input_float_little_endian ic = let n = ref Int64.zero in for i = 0 to 7 do let b = input_byte ic in n := Int64.logor !n (Int64.shift_left (Int64.of_int b) (i*8)) done; Int64.float_of_bits !n let input_binary_float = input_float_little_endian let input_binary_floats ic array = for i = 0 to Array.length array - 1 do array.(i) <- input_binary_float ic done end (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/circe2/src/OUnit.ml =================================================================== --- trunk/circe2/src/OUnit.ml (revision 8272) +++ trunk/circe2/src/OUnit.ml (revision 8273) @@ -1,805 +1,805 @@ -(* circe2/oUnit.ml -- *) +(* oUnit.ml -- *) (***********************************************************************) (* The OUnit library *) (* *) (* Copyright (C) 2002-2008 Maas-Maarten Zeeman. *) (* Copyright (C) 2010 OCamlCore SARL *) (* *) (***********************************************************************) (* Version 1.1.2, with minor modifications by Thorsten Ohl *) (************************************************************************ The package OUnit is copyright by Maas-Maarten Zeeman and OCamlCore SARL. Permission is hereby granted, free of charge, to any person obtaining a copy of this document and the OUnit software ("the Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. The Software is provided ``as is'', without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall Maas-Maarten Zeeman be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the software. ************************************************************************) open Format (* TODO: really use Format in printf call. Most of the time, not * cuts/spaces/boxes are used *) let global_verbose = ref false let buff_printf f = let buff = Buffer.create 13 in let fmt = formatter_of_buffer buff in f fmt; pp_print_flush fmt (); Buffer.contents buff let bracket set_up f tear_down () = let fixture = set_up () in let () = try let () = f fixture in tear_down fixture with e -> let () = tear_down fixture in raise e in () let bracket_tmpfile ?(prefix="ounit-") ?(suffix=".txt") ?mode f = bracket (fun () -> Filename.open_temp_file ?mode prefix suffix) f (fun (fn, chn) -> begin try close_out chn with _ -> () end; begin try Sys.remove fn with _ -> () end) exception Skip of string let skip_if b msg = if b then raise (Skip msg) exception Todo of string let todo msg = raise (Todo msg) let assert_failure msg = failwith ("OUnit: " ^ msg) let assert_bool msg b = if not b then assert_failure msg let assert_string str = if not (str = "") then assert_failure str let assert_equal ?(cmp = ( = )) ?printer ?pp_diff ?msg expected actual = let get_error_string () = (* let max_len = pp_get_margin fmt () in *) (* let ellipsis_text = "[...]" in *) let print_ellipsis p fmt s = (* TODO: find a way to do this let res = p s in let len = String.length res in if diff <> None && len > max_len then begin let len_with_ellipsis = (max_len - (String.length ellipsis_text)) / 2 in (* TODO: we should use %a here to print values *) fprintf fmt "@[%s[...]%s@]" (String.sub res 0 len_with_ellipsis) (String.sub res (len - len_with_ellipsis) len_with_ellipsis) end else begin (* TODO: we should use %a here to print values *) fprintf fmt "@[%s@]" res end *) pp_print_string fmt (p s) in let res = buff_printf (fun fmt -> pp_open_vbox fmt 0; begin match msg with | Some s -> pp_open_box fmt 0; pp_print_string fmt s; pp_close_box fmt (); pp_print_cut fmt () | None -> () end; begin match printer with | Some p -> let p_ellipsis = print_ellipsis p in fprintf fmt "@[expected: @[%a@]@ but got: @[%a@]@]@," p_ellipsis expected p_ellipsis actual | None -> fprintf fmt "@[not equal@]@," end; begin match pp_diff with | Some d -> fprintf fmt "@[differences: %a@]@," d (expected, actual) | None -> () end; pp_close_box fmt ()) in let len = String.length res in if len > 0 && res.[len - 1] = '\n' then String.sub res 0 (len - 1) else res in if not (cmp expected actual) then assert_failure (get_error_string ()) let assert_command ?(exit_code=Unix.WEXITED 0) ?(sinput=Stream.of_list []) ?(foutput=ignore) ?(use_stderr=true) ?env ?verbose prg args = let verbose = match verbose with | Some v -> v | None -> !global_verbose in bracket_tmpfile (fun (fn_out, chn_out) -> let cmd_print fmt = let () = match env with | Some e -> begin pp_print_string fmt "env"; Array.iter (fprintf fmt "@ %s") e; pp_print_space fmt () end | None -> () in pp_print_string fmt prg; List.iter (fprintf fmt "@ %s") args in (* Start the process *) let in_write = Unix.dup (Unix.descr_of_out_channel chn_out) in let (out_read, out_write) = Unix.pipe () in let err = if use_stderr then in_write else Unix.stderr in let args = Array.of_list (prg :: args) in let pid = Unix.set_close_on_exec out_write; if verbose then printf "@[Starting command '%t'@]\n" cmd_print; match env with | Some e -> Unix.create_process_env prg args e out_read in_write err | None -> Unix.create_process prg args out_read in_write err in let () = Unix.close out_read; Unix.close in_write in let () = (* Dump sinput into the process stdin *) - let buff = " " in + let buff = Bytes.make 1 ' ' in Stream.iter (fun c -> let _i : int = - buff.[0] <- c; + Bytes.set buff 0 c; Unix.write out_write buff 0 1 in ()) sinput; Unix.close out_write in let _, real_exit_code = let rec wait_intr () = try Unix.waitpid [] pid with Unix.Unix_error (Unix.EINTR, _, _) -> wait_intr () in wait_intr () in let exit_code_printer = function | Unix.WEXITED n -> Printf.sprintf "exit code %d" n | Unix.WSTOPPED n -> Printf.sprintf "stopped by signal %d" n | Unix.WSIGNALED n -> Printf.sprintf "killed by signal %d" n in (* Dump process output to stderr *) if verbose then begin let chn = open_in fn_out in - let buff = String.make 4096 'X' in + let buff = Bytes.make 4096 'X' in let len = ref (-1) in while !len <> 0 do - len := input chn buff 0 (String.length buff); - printf "%s" (String.sub buff 0 !len); + len := input chn buff 0 (Bytes.length buff); + printf "%s" (Bytes.sub_string buff 0 !len); done; printf "@?"; close_in chn end; (* Check process status *) assert_equal ~msg:(buff_printf (fun fmt -> fprintf fmt "@[Exit status of command '%t'@]" cmd_print)) ~printer:exit_code_printer exit_code real_exit_code; begin let chn = open_in fn_out in try foutput (Stream.of_channel chn) with e -> close_in chn; raise e end) () let raises f = try f (); None with e -> Some e let assert_raises ?msg exn (f: unit -> 'a) = let pexn = Printexc.to_string in let get_error_string () = let str = Format.sprintf "expected exception %s, but no exception was raised." (pexn exn) in match msg with | None -> assert_failure str | Some s -> assert_failure (Format.sprintf "%s\n%s" s str) in match raises f with | None -> assert_failure (get_error_string ()) | Some e -> assert_equal ?msg ~printer:pexn exn e (* Compare floats up to a given relative error *) let cmp_float ?(epsilon = 0.00001) a b = abs_float (a -. b) <= epsilon *. (abs_float a) || abs_float (a -. b) <= epsilon *. (abs_float b) (* Now some handy shorthands *) let (@?) = assert_bool (* The type of test function *) type test_fun = unit -> unit (* The type of tests *) type test = | TestCase of test_fun | TestList of test list | TestLabel of string * test (* Some shorthands which allows easy test construction *) let (>:) s t = TestLabel(s, t) (* infix *) let (>::) s f = TestLabel(s, TestCase(f)) (* infix *) let (>:::) s l = TestLabel(s, TestList(l)) (* infix *) (* Utility function to manipulate test *) let rec test_decorate g = function | TestCase f -> TestCase (g f) | TestList tst_lst -> TestList (List.map (test_decorate g) tst_lst) | TestLabel (str, tst) -> TestLabel (str, test_decorate g tst) (* Return the number of available tests *) let rec test_case_count = function | TestCase _ -> 1 | TestLabel (_, t) -> test_case_count t | TestList l -> List.fold_left (fun c t -> c + test_case_count t) 0 l type node = | ListItem of int | Label of string type path = node list let string_of_node = function | ListItem n -> string_of_int n | Label s -> s let string_of_path path = String.concat ":" (List.rev_map string_of_node path) (* Some helper function, they are generally applicable *) (* Applies function f in turn to each element in list. Function f takes one element, and integer indicating its location in the list *) let mapi f l = let rec rmapi cnt l = match l with | [] -> [] | h :: t -> (f h cnt) :: (rmapi (cnt + 1) t) in rmapi 0 l let fold_lefti f accu l = let rec rfold_lefti cnt accup l = match l with | [] -> accup | h::t -> rfold_lefti (cnt + 1) (f accup h cnt) t in rfold_lefti 0 accu l (* Returns all possible paths in the test. The order is from test case to root *) let test_case_paths test = let rec tcps path test = match test with | TestCase _ -> [path] | TestList tests -> List.concat (mapi (fun t i -> tcps ((ListItem i)::path) t) tests) | TestLabel (l, t) -> tcps ((Label l)::path) t in tcps [] test (* Test filtering with their path *) module SetTestPath = Set.Make(String) let test_filter ?(skip=false) only test = let set_test = List.fold_left (fun st str -> SetTestPath.add str st) SetTestPath.empty only in let rec filter_test path tst = if SetTestPath.mem (string_of_path path) set_test then begin Some tst end else begin match tst with | TestCase f -> begin if skip then Some (TestCase (fun () -> skip_if true "Test disabled"; f ())) else None end | TestList tst_lst -> begin let ntst_lst = fold_lefti (fun ntst_lst tst i -> let nntst_lst = match filter_test ((ListItem i) :: path) tst with | Some tst -> tst :: ntst_lst | None -> ntst_lst in nntst_lst) [] tst_lst in if not skip && ntst_lst = [] then None else Some (TestList (List.rev ntst_lst)) end | TestLabel (lbl, tst) -> begin let ntst_opt = filter_test ((Label lbl) :: path) tst in match ntst_opt with | Some ntst -> Some (TestLabel (lbl, ntst)) | None -> if skip then Some (TestLabel (lbl, tst)) else None end end in filter_test [] test (* The possible test results *) type test_result = | RSuccess of path | RFailure of path * string | RError of path * string | RSkip of path * string | RTodo of path * string let is_success = function | RSuccess _ -> true | RFailure _ | RError _ | RSkip _ | RTodo _ -> false let is_failure = function | RFailure _ -> true | RSuccess _ | RError _ | RSkip _ | RTodo _ -> false let is_error = function | RError _ -> true | RSuccess _ | RFailure _ | RSkip _ | RTodo _ -> false let is_skip = function | RSkip _ -> true | RSuccess _ | RFailure _ | RError _ | RTodo _ -> false let is_todo = function | RTodo _ -> true | RSuccess _ | RFailure _ | RError _ | RSkip _ -> false let result_flavour = function | RError _ -> "Error" | RFailure _ -> "Failure" | RSuccess _ -> "Success" | RSkip _ -> "Skip" | RTodo _ -> "Todo" let result_path = function | RSuccess path | RError (path, _) | RFailure (path, _) | RSkip (path, _) | RTodo (path, _) -> path let result_msg = function | RSuccess _ -> "Success" | RError (_, msg) | RFailure (_, msg) | RSkip (_, msg) | RTodo (_, msg) -> msg (* Returns true if the result list contains successes only *) let rec was_successful = function | [] -> true | RSuccess _::t | RSkip _::t -> was_successful t | RFailure _::_ | RError _::_ | RTodo _::_ -> false (* Events which can happen during testing *) type test_event = | EStart of path | EEnd of path | EResult of test_result let maybe_backtrace () = if Printexc.backtrace_status () then "\n" ^ Printexc.get_backtrace () else "" (* Run all tests, report starts, errors, failures, and return the results *) let perform_test report test = let run_test_case f path = try f (); RSuccess path with | Failure s -> RFailure (path, s ^ maybe_backtrace ()) | Skip s -> RSkip (path, s) | Todo s -> RTodo (path, s) | s -> RError (path, Printexc.to_string s ^ maybe_backtrace ()) in let rec run_test path results = function | TestCase(f) -> begin let result = report (EStart path); run_test_case f path in report (EResult result); report (EEnd path); result::results end | TestList (tests) -> begin fold_lefti (fun results t cnt -> run_test ((ListItem cnt)::path) results t) results tests end | TestLabel (label, t) -> begin run_test ((Label label)::path) results t end in run_test [] [] test (* Function which runs the given function and returns the running time of the function, and the original result in a tuple *) let time_fun f x y = let begin_time = Unix.gettimeofday () in (Unix.gettimeofday () -. begin_time, f x y) (* A simple (currently too simple) text based test runner *) let run_test_tt ?verbose test = let verbose = match verbose with | Some v -> v | None -> !global_verbose in let printf = Format.printf in let separator1 = String.make (get_margin ()) '=' in let separator2 = String.make (get_margin ()) '-' in let string_of_result = function | RSuccess _ -> if verbose then "ok\n" else "." | RFailure (_, _) -> if verbose then "FAIL\n" else "F" | RError (_, _) -> if verbose then "ERROR\n" else "E" | RSkip (_, _) -> if verbose then "SKIP\n" else "S" | RTodo (_, _) -> if verbose then "TODO\n" else "T" in let report_event = function | EStart p -> if verbose then printf "%s ...\n" (string_of_path p) | EEnd _ -> () | EResult result -> printf "%s@?" (string_of_result result) in let print_result_list results = List.iter (fun result -> printf "%s\n%s: %s\n\n%s\n%s\n" separator1 (result_flavour result) (string_of_path (result_path result)) (result_msg result) separator2) results in (* Now start the test *) let running_time, results = time_fun perform_test report_event test in let errors = List.filter is_error results in let failures = List.filter is_failure results in let skips = List.filter is_skip results in let todos = List.filter is_todo results in if not verbose then printf "\n"; (* Print test report *) print_result_list errors; print_result_list failures; printf "Ran: %d tests in: %.2f seconds.\n" (List.length results) running_time; (* Print final verdict *) if was_successful results then ( if skips = [] then printf "OK" else printf "OK: Cases: %d Skip: %d\n" (test_case_count test) (List.length skips) ) else printf "FAILED: Cases: %d Tried: %d Errors: %d \ Failures: %d Skip:%d Todo:%d\n" (test_case_count test) (List.length results) (List.length errors) (List.length failures) (List.length skips) (List.length todos); (* Return the results possibly for further processing *) results (* Call this one from you test suites *) let run_test_tt_main ?(arg_specs=[]) ?(set_verbose=ignore) suite = let only_test = ref [] in let () = Arg.parse (Arg.align [ "-verbose", Arg.Set global_verbose, " Run the test in verbose mode."; "-only-test", Arg.String (fun str -> only_test := str :: !only_test), "path Run only the selected test"; "-list-test", Arg.Unit (fun () -> List.iter (fun pth -> print_endline (string_of_path pth)) (test_case_paths suite); exit 0), " List tests"; ] @ arg_specs ) (fun x -> raise (Arg.Bad ("Bad argument : " ^ x))) ("usage: " ^ Sys.argv.(0) ^ " [-verbose] [-only-test path]*") in let nsuite = if !only_test = [] then suite else begin match test_filter ~skip:true !only_test suite with | Some test -> test | None -> failwith ("Filtering test "^ (String.concat ", " !only_test)^ " lead to no test") end in let result = set_verbose !global_verbose; run_test_tt ~verbose:!global_verbose nsuite in if not (was_successful result) then exit 1 else result Index: trunk/circe2/src/events.ml =================================================================== --- trunk/circe2/src/events.ml (revision 8272) +++ trunk/circe2/src/events.ml (revision 8273) @@ -1,210 +1,210 @@ (* circe2/events.ml -- *) (* Copyright (C) 2001-2019 by Thorsten Ohl Circe2 is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. Circe2 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 General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \subsubsection{Reading Bigarrays} *) (* Reading big arrays efficiently is not trivial, if we don't know the size of the arrays beforehand. Here we use the brute force approach of reading a list of not-so-big arrays and blitting them into the resulting array later. This avoids a second reading of the file, but temporarily needs twice the memory. *) open Bigarray open Printf type t = (float, float64_elt, fortran_layout) Array2.t exception Incomplete of int * t (* Read lines from a channel into the columns of a bigarray. If the file turns out to be short, the exception [Incomplete (i2, array)] is raised with the number of columns actually read. *) let read_lines ic reader array i2_first i2_last = let i2 = ref i2_first in try while !i2 <= i2_last do let line = input_line ic in if line <> "" then begin reader array !i2 line; incr i2 end done with | End_of_file -> raise (Incomplete (pred !i2, array)) (* Decode a line of floating point numbers into a column of a bigarray. *) (* Fortran allows ['d'] and ['D'] as exponent starter, but O'Caml's [Genlex] doesn't accept it. *) let normalize_ascii_floats orig = - let normalized = String.copy orig in - for i = 0 to String.length normalized - 1 do - let c = normalized.[i] in + let normalized = Bytes.of_string orig in + for i = 0 to Bytes.length normalized - 1 do + let c = Bytes.get normalized i in if c = 'd' || c = 'D' then - normalized.[i] <- 'E' + Bytes.set normalized i 'E' done; - normalized + Bytes.to_string normalized let lexer = Genlex.make_lexer [] let next_float s = match Stream.next s with | Genlex.Int n -> float n | Genlex.Float x -> x | _ -> invalid_arg "Events.int_as_float" let read_floats array i2 line = let tokens = lexer (Stream.of_string (normalize_ascii_floats line)) in for i1 = 1 to Array2.dim1 array do Array2.set array i1 i2 (next_float tokens) done (*i let read_floats array i2 line = let tokens = lexer (Stream.of_string (normalize_ascii_floats line)) in for i1 = 1 to Array2.dim1 array do array.{i1,i2} <- next_float tokens done i*) (* Try to read the columns of a bigarray from a channel. If the file turns out to be short, the exception~[Incomplete (dim2, array)] is raised with the number of columns actually read. *) let try_of_ascii_channel dim1 dim2 ic = let array = Array2.create float64 fortran_layout dim1 dim2 in read_lines ic read_floats array 1 dim2; (dim2, array) (* Read a~[dim1] floating point numbers per line into the columns of a reverted list of bigarrays, each with a maximum of~[chunk] columns. *) let rev_list_of_ascii_channel chunk dim1 ic = let rec rev_list_of_ascii_channel' acc = let continue = try let acc' = try_of_ascii_channel dim1 chunk ic :: acc in fun () -> rev_list_of_ascii_channel' acc' with | Incomplete (len, a) -> fun () -> (len, a) :: acc in continue () in rev_list_of_ascii_channel' [] (* Concatenate a list of bigarrays~$[(l_n,a_n);\ldots;(l_2,a_2);(l_1,a_1)]$ in reverse order~$a_1a_2\ldots a_n$. Of each array~$a_i$, only the first~$l_i$ columns are used. If the optional [file] name is present, map the corresponding file to the bigarray. We can close the file descriptor immediately, since \verb+close(2)+ does \emph{not} \verb+munmap(2)+. *) let create_array ?file dim1 dim2 = match file with | None -> Array2.create float64 fortran_layout dim1 dim2 | Some name -> let fd = Unix.openfile name [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o644 in let a = Array2.map_file fd float64 fortran_layout true dim1 dim2 in Unix.close fd; a let rev_concat ?file arrays = let sum_dim2 = List.fold_left (fun sum (dim2, _) -> sum + dim2) 0 arrays in if sum_dim2 <= 0 then invalid_arg "Events.rev_concat"; let dim1 = Array2.dim1 (snd (List.hd arrays)) in let array = create_array ?file dim1 sum_dim2 in let _ = List.fold_right (fun (dim2, a) ofs -> Array2.blit (Array2.sub_right a 1 dim2) (Array2.sub_right array ofs dim2); ofs + dim2) arrays 1 in array let of_ascii_channel ?file ?(chunk = 100000) dim1 ic = rev_concat ?file (rev_list_of_ascii_channel chunk dim1 ic) let of_ascii_file ?file ?chunk dim1 name = let ic = open_in name in let a = of_ascii_channel ?file ?chunk dim1 ic in close_in ic; a (* We can close the file descriptor immediately, since \verb+close(2)+ does \emph{not} \verb+munmap(2)+. *) let of_binary_file dim1 file = let fd = Unix.openfile file [Unix.O_RDONLY] 0o644 in let a = Array2.map_file fd float64 fortran_layout false dim1 (-1) in Unix.close fd; a let shared_map_binary_file dim1 file = let fd = Unix.openfile file [Unix.O_RDWR] 0o644 in let a = Array2.map_file fd float64 fortran_layout true dim1 (-1) in Unix.close fd; a let to_ascii_channel oc a = let dim1 = Array2.dim1 a and dim2 = Array2.dim2 a in for i2 = 1 to dim2 do for i1 = 1 to dim1 do fprintf oc " %.17E" (Array2.get a i1 i2) done; fprintf oc "\n" done (*i let to_ascii_channel oc a = let dim1 = Array2.dim1 a and dim2 = Array2.dim2 a in for i2 = 1 to dim2 do for i1 = 1 to dim1 do fprintf oc " %.17E" a.{i1,i2} done; fprintf oc "\n" done i*) let to_ascii_file name a = let oc = open_out name in to_ascii_channel oc a; close_out oc let to_binary_file file a = let fd = Unix.openfile file [Unix.O_RDWR; Unix.O_CREAT; Unix.O_TRUNC] 0o644 in let a' = Array2.map_file fd float64 fortran_layout true (Array2.dim1 a) (Array2.dim2 a) in Unix.close fd; Array2.blit a a' let rescale scale1 scale2 data = for i2 = 1 to Array2.dim2 data do Array2.set data 1 i2 (Array2.get data 1 i2 /. scale1); Array2.set data 2 i2 (Array2.get data 2 i2 /. scale2) done (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*)