--- obrowser-1.1.1/Makefile.orig 2011-07-05 16:15:30.000000000 +0200 +++ obrowser-1.1.1/Makefile 2011-07-05 16:16:42.000000000 +0200 @@ -16,9 +16,9 @@ EXAMPLES = $(patsubst examples/%,%, $(wildcard examples/*)) EXAMPLES_TARGETS = $(patsubst examples/%,%.example, $(wildcard examples/*)) OCAMLFIND = ocamlfind -.PHONY: tuto dist plugin lwt +.PHONY: tuto dist plugin lwt AXO -all: .check_version rt/caml/stdlib.cma vm.js tuto $(EXAMPLES_TARGETS) examples.html AXO lwt +all: .check_version rt/caml/stdlib.cma vm.js tuto AXO $(EXAMPLES_TARGETS) examples.html lwt .check_version: @[ "$(shell ocamlc -vnum)" = "3.12.0" ] || \ --- obrowser-1.1.1.orig/Makefile 2011-04-20 18:26:44.000000000 +0200 +++ obrowser-1.1.1/Makefile 2012-03-12 16:55:44.000000000 +0100 @@ -21,10 +21,11 @@ all: .check_version rt/caml/stdlib.cma vm.js tuto $(EXAMPLES_TARGETS) examples.html AXO lwt .check_version: - @[ "$(shell ocamlc -vnum)" = "3.12.0" ] || \ - [ "$(shell ocamlc -vnum)" = "3.12.1" ] || \ - ( echo "You need ocaml version 3.12.0 or 3.12.1"; \ - exit 1 ) + @case `ocaml -vnum` in \ + 3.1[2-9].*);; \ + 4.*);; \ + *) echo "You need ocaml version 3.12.0 or later"; exit 1;; \ + esac touch $@ %.example: --- obrowser-1.1.1.orig/rt/caml/pervasives.mli 2011-04-20 18:26:44.000000000 +0200 +++ obrowser-1.1.1/rt/caml/pervasives.mli 2012-01-12 01:07:49.000000000 +0100 @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -52,24 +52,24 @@ Equality between cyclic data structures may not terminate. *) external ( <> ) : 'a -> 'a -> bool = "%notequal" -(** Negation of {!Pervasives.(=)}. *) +(** Negation of {!Pervasives.( = )}. *) external ( < ) : 'a -> 'a -> bool = "%lessthan" -(** See {!Pervasives.(>=)}. *) +(** See {!Pervasives.( >= )}. *) external ( > ) : 'a -> 'a -> bool = "%greaterthan" -(** See {!Pervasives.(>=)}. *) +(** See {!Pervasives.( >= )}. *) external ( <= ) : 'a -> 'a -> bool = "%lessequal" -(** See {!Pervasives.(>=)}. *) +(** See {!Pervasives.( >= )}. *) external ( >= ) : 'a -> 'a -> bool = "%greaterequal" (** Structural ordering functions. These functions coincide with the usual orderings over integers, characters, strings and floating-point numbers, and extend them to a total ordering over all types. - The ordering is compatible with [(=)]. As in the case - of [(=)], mutable structures are compared by contents. + The ordering is compatible with [( = )]. As in the case + of [( = )], mutable structures are compared by contents. Comparison between functional values raises [Invalid_argument]. Comparison between cyclic structures may not terminate. *) @@ -108,12 +108,12 @@ mutable fields and objects with mutable instance variables, [e1 == e2] is true if and only if physical modification of [e1] also affects [e2]. - On non-mutable types, the behavior of [(==)] is + On non-mutable types, the behavior of [( == )] is implementation-dependent; however, it is guaranteed that [e1 == e2] implies [compare e1 e2 = 0]. *) external ( != ) : 'a -> 'a -> bool = "%noteq" -(** Negation of {!Pervasives.(==)}. *) +(** Negation of {!Pervasives.( == )}. *) (** {6 Boolean operations} *) @@ -229,7 +229,7 @@ (** {6 Floating-point arithmetic} - Caml's floating-point numbers follow the + OCaml's floating-point numbers follow the IEEE 754 standard, using double precision (64 bits) numbers. Floating-point operations never raise an exception on overflow, underflow, division by zero, etc. Instead, special IEEE numbers @@ -310,10 +310,18 @@ Result is in radians and is between [-pi/2] and [pi/2]. *) external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" -(** [atan x y] returns the arc tangent of [y /. x]. The signs of [x] +(** [atan2 y x] returns the arc tangent of [y /. x]. The signs of [x] and [y] are used to determine the quadrant of the result. Result is in radians and is between [-pi] and [pi]. *) +external hypot : float -> float -> float + = "caml_hypot_float" "caml_hypot" "float" +(** [hypot x y] returns [sqrt(x *. x + y *. y)], that is, the length + of the hypotenuse of a right-angled triangle with sides of length + [x] and [y], or, equivalently, the distance of the point [(x,y)] + to origin. + @since 3.13.0 *) + external cosh : float -> float = "caml_cosh_float" "cosh" "float" (** Hyperbolic cosine. Argument is in radians. *) @@ -337,6 +345,14 @@ external abs_float : float -> float = "%absfloat" (** [abs_float f] returns the absolute value of [f]. *) +external copysign : float -> float -> float + = "caml_copysign_float" "caml_copysign" "float" +(** [copysign x y] returns a float whose absolute value is that of [x] + and whose sign is that of [y]. If [x] is [nan], returns [nan]. + If [y] is [nan], returns either [x] or [-. x], but it is not + specified which. + @since 3.13.0 *) + external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" (** [mod_float a b] returns the remainder of [a] with respect to [b]. The returned value is [a -. n *. b], where [n] @@ -505,7 +521,7 @@ (** The standard output for the process. *) val stderr : out_channel -(** The standard error ouput for the process. *) +(** The standard error output for the process. *) (** {7 Output functions on standard output} *) @@ -642,7 +658,7 @@ The given integer is taken modulo 2{^32}. The only reliable way to read it back is through the {!Pervasives.input_binary_int} function. The format is compatible across - all machines for a given version of Objective Caml. *) + all machines for a given version of OCaml. *) val output_value : out_channel -> 'a -> unit (** Write the representation of a structured value of any type @@ -855,12 +871,16 @@ (** Format strings have a general and highly polymorphic type [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. The two simplified types, [format] and [format4] below are - included for backward compatibility with earlier releases of Objective - Caml. + included for backward compatibility with earlier releases of OCaml. ['a] is the type of the parameters of the format, - ['c] is the result type for the "printf"-style function, - and ['b] is the type of the first argument given to - [%a] and [%t] printing functions. *) + ['b] is the type of the first argument given to + [%a] and [%t] printing functions, + ['c] is the type of the argument transmitted to the first argument of + "kprintf"-style functions, + ['d] is the result type for the "scanf"-style functions, + ['e] is the type of the receiver function for the "scanf"-style functions, + ['f] is the result type for the "printf"-style function. + *) type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 @@ -888,7 +908,7 @@ (** Terminate the process, returning the given status code to the operating system: usually 0 to indicate no errors, and a small positive integer to indicate failure. - All open output channels are flushed with flush_all. + All open output channels are flushed with [flush_all]. An implicit [exit 0] is performed each time a program terminates normally. An implicit [exit 2] is performed if the program terminates early because of an uncaught exception. *) --- obrowser-1.1.1.orig/rt/caml/pervasives.ml 2011-04-20 18:26:44.000000000 +0200 +++ obrowser-1.1.1/rt/caml/pervasives.ml 2012-01-12 17:04:04.000000000 +0100 @@ -91,6 +91,8 @@ external asin : float -> float = "caml_asin_float" "asin" "float" external atan : float -> float = "caml_atan_float" "atan" "float" external atan2 : float -> float -> float = "caml_atan2_float" "atan2" "float" +external hypot : float -> float -> float + = "caml_hypot_float" "caml_hypot" "float" external cos : float -> float = "caml_cos_float" "cos" "float" external cosh : float -> float = "caml_cosh_float" "cosh" "float" external log : float -> float = "caml_log_float" "log" "float" @@ -104,6 +106,8 @@ external ceil : float -> float = "caml_ceil_float" "ceil" "float" external floor : float -> float = "caml_floor_float" "floor" "float" external abs_float : float -> float = "%absfloat" +external copysign : float -> float -> float + = "caml_copysign_float" "caml_copysign" "float" external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" external frexp : float -> float * int = "caml_frexp_float" external ldexp : float -> int -> float = "caml_ldexp_float" --- obrowser-1.1.1.orig/rt/caml/list.ml 2011-04-20 18:26:44.000000000 +0200 +++ obrowser-1.1.1/rt/caml/list.ml 2012-01-12 17:30:31.000000000 +0100 @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -56,6 +56,12 @@ [] -> [] | a::l -> let r = f a in r :: map f l +let rec mapi i f = function + [] -> [] + | a::l -> let r = f i a in r :: mapi (i + 1) f l + +let mapi f l = mapi 0 f l + let rev_map f l = let rec rmap_f accu = function | [] -> accu @@ -68,6 +74,12 @@ [] -> () | a::l -> f a; iter f l +let rec iteri i f = function + [] -> () + | a::l -> f i a; iteri (i + 1) f l + +let iteri f l = iteri 0 f l + let rec fold_left f accu l = match l with [] -> accu --- obrowser-1.1.1.orig/rt/caml/list.mli 2011-04-20 18:26:44.000000000 +0200 +++ obrowser-1.1.1/rt/caml/list.mli 2012-01-12 17:30:31.000000000 +0100 @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -75,11 +75,25 @@ [a1; ...; an]. It is equivalent to [begin f a1; f a2; ...; f an; () end]. *) +val iteri : (int -> 'a -> unit) -> 'a list -> unit +(** Same as {!List.iter}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. + @since 3.13.0 +*) + val map : ('a -> 'b) -> 'a list -> 'b list (** [List.map f [a1; ...; an]] applies function [f] to [a1, ..., an], and builds the list [[f a1; ...; f an]] with the results returned by [f]. Not tail-recursive. *) +val mapi : (int -> 'a -> 'b) -> 'a list -> 'b list +(** Same as {!List.map}, but the function is applied to the index of + the element as first argument (counting from 0), and the element + itself as second argument. Not tail-recursive. + @since 3.13.0 +*) + val rev_map : ('a -> 'b) -> 'a list -> 'b list (** [List.rev_map f l] gives the same result as {!List.rev}[ (]{!List.map}[ f l)], but is tail-recursive and --- obrowser-1.1.1-old/rt/caml/pervasives.mli 2013-06-20 13:50:19.000000000 +0200 +++ obrowser-1.1.1/rt/caml/pervasives.mli 2013-06-20 13:50:59.000000000 +0200 @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: pervasives.mli 10548 2010-06-09 10:26:19Z weis $ *) - (** The initially opened module. This module provides the basic operations over the built-in types @@ -122,7 +120,7 @@ (** The boolean negation. *) external ( && ) : bool -> bool -> bool = "%sequand" -(** The boolean ``and''. Evaluation is sequential, left-to-right: +(** The boolean 'and'. Evaluation is sequential, left-to-right: in [e1 && e2], [e1] is evaluated first, and if it returns [false], [e2] is not evaluated at all. *) @@ -130,7 +128,7 @@ (** @deprecated {!Pervasives.( && )} should be used instead. *) external ( || ) : bool -> bool -> bool = "%sequor" -(** The boolean ``or''. Evaluation is sequential, left-to-right: +(** The boolean 'or'. Evaluation is sequential, left-to-right: in [e1 || e2], [e1] is evaluated first, and if it returns [true], [e2] is not evaluated at all. *) @@ -138,6 +136,20 @@ (** @deprecated {!Pervasives.( || )} should be used instead.*) +(** {6 Composition operators} *) + +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" +(** Reverse-application operator: [x |> f |> g] is exactly equivalent + to [g (f (x))]. + @since 4.01 +*) + +external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" +(** Application operator: [g @@ f @@ x] is exactly equivalent to + [g (f (x))]. + @since 4.01 +*) + (** {6 Integer arithmetic} *) (** Integers are 31 bits wide (or 63 bits on 64-bit processors). @@ -234,7 +246,7 @@ Floating-point operations never raise an exception on overflow, underflow, division by zero, etc. Instead, special IEEE numbers are returned as appropriate, such as [infinity] for [1.0 /. 0.0], - [neg_infinity] for [-1.0 /. 0.0], and [nan] (``not a number'') + [neg_infinity] for [-1.0 /. 0.0], and [nan] ('not a number') for [0.0 /. 0.0]. These special numbers then propagate through floating-point computations as expected: for instance, [1.0 /. infinity] is [0.0], and any arithmetic operation with [nan] @@ -320,7 +332,7 @@ of the hypotenuse of a right-angled triangle with sides of length [x] and [y], or, equivalently, the distance of the point [(x,y)] to origin. - @since 3.13.0 *) + @since 4.00.0 *) external cosh : float -> float = "caml_cosh_float" "cosh" "float" (** Hyperbolic cosine. Argument is in radians. *) @@ -351,7 +363,7 @@ and whose sign is that of [y]. If [x] is [nan], returns [nan]. If [y] is [nan], returns either [x] or [-. x], but it is not specified which. - @since 3.13.0 *) + @since 4.00.0 *) external mod_float : float -> float -> float = "caml_fmod_float" "fmod" "float" (** [mod_float a b] returns the remainder of [a] with respect to @@ -395,7 +407,7 @@ val nan : float (** A special floating-point value denoting the result of an undefined operation such as [0.0 /. 0.0]. Stands for - ``not a number''. Any floating-point operation with [nan] as + 'not a number'. Any floating-point operation with [nan] as argument returns [nan] as result. As for floating-point comparisons, [=], [<], [<=], [>] and [>=] return [false] and [<>] returns [true] if one or both of their arguments is [nan]. *) @@ -461,7 +473,9 @@ (** {6 String conversion functions} *) val string_of_bool : bool -> string -(** Return the string representation of a boolean. *) +(** Return the string representation of a boolean. As the returned values + may be shared, the user should not modify them directly. +*) val bool_of_string : string -> bool (** Convert the given string to a boolean. @@ -506,7 +520,9 @@ (** List concatenation. *) -(** {6 Input/output} *) +(** {6 Input/output} + Note: all input/output functions can raise [Sys_error] when the system + calls they invoke fail. *) type in_channel (** The type of input channel. *) @@ -864,23 +880,73 @@ (** {6 Operations on format strings} *) -(** Format strings are used to read and print data using formatted input - functions in module {!Scanf} and formatted output in modules {!Printf} and - {!Format}. *) +(** Format strings are character strings with special lexical conventions + that defines the functionality of formatted input/output functions. Format + strings are used to read data with formatted input functions from module + {!Scanf} and to print data with formatted output functions from modules + {!Printf} and {!Format}. + + Format strings are made of three kinds of entities: + - {e conversions specifications}, introduced by the special character ['%'] + followed by one or more characters specifying what kind of argument to + read or print, + - {e formatting indications}, introduced by the special character ['@'] + followed by one or more characters specifying how to read or print the + argument, + - {e plain characters} that are regular characters with usual lexical + conventions. Plain characters specify string literals to be read in the + input or printed in the output. + + There is an additional lexical rule to escape the special characters ['%'] + and ['@'] in format strings: if a special character follows a ['%'] + character, it is treated as a plain character. In other words, ["%%"] is + considered as a plain ['%'] and ["%@"] as a plain ['@']. + + For more information about conversion specifications and formatting + indications available, read the documentation of modules {!Scanf}, + {!Printf} and {!Format}. +*) (** Format strings have a general and highly polymorphic type [('a, 'b, 'c, 'd, 'e, 'f) format6]. Type [format6] is built in. The two simplified types, [format] and [format4] below are - included for backward compatibility with earlier releases of OCaml. - ['a] is the type of the parameters of the format, - ['b] is the type of the first argument given to - [%a] and [%t] printing functions, - ['c] is the type of the argument transmitted to the first argument of - "kprintf"-style functions, - ['d] is the result type for the "scanf"-style functions, - ['e] is the type of the receiver function for the "scanf"-style functions, - ['f] is the result type for the "printf"-style function. - *) + included for backward compatibility with earlier releases of + OCaml. + + The meaning of format string type parameters is as follows: + + - ['a] is the type of the parameters of the format for formatted output + functions ([printf]-style functions); + ['a] is the type of the values read by the format for formatted input + functions ([scanf]-style functions). + + - ['b] is the type of input source for formatted input functions and the + type of output target for formatted output functions. + For [printf]-style functions from module [Printf], ['b] is typically + [out_channel]; + for [printf]-style functions from module [Format], ['b] is typically + [Format.formatter]; + for [scanf]-style functions from module [Scanf], ['b] is typically + [Scanf.Scanning.in_channel]. + + Type argument ['b] is also the type of the first argument given to + user's defined printing functions for [%a] and [%t] conversions, + and user's defined reading functions for [%r] conversion. + + - ['c] is the type of the result of the [%a] and [%t] printing + functions, and also the type of the argument transmitted to the + first argument of [kprintf]-style functions or to the + [kscanf]-style functions. + + - ['d] is the type of parameters for the [scanf]-style functions. + + - ['e] is the type of the receiver function for the [scanf]-style functions. + + - ['f] is the final result type of a formatted input/output function + invocation: for the [printf]-style functions, it is typically [unit]; + for the [scanf]-style functions, it is typically the result type of the + receiver function. +*) type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 @@ -892,14 +958,22 @@ ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('a, 'b, 'c, 'd, 'e, 'f) format6 = "%identity" (** [format_of_string s] returns a format string read from the string - literal [s]. *) + literal [s]. + Note: [format_of_string] can not convert a string argument that is not a + literal. If you need this functionality, use the more general + {!Scanf.format_from_string} function. +*) val ( ^^ ) : ('a, 'b, 'c, 'd, 'e, 'f) format6 -> ('f, 'b, 'c, 'e, 'g, 'h) format6 -> ('a, 'b, 'c, 'd, 'g, 'h) format6 -(** [f1 ^^ f2] catenates formats [f1] and [f2]. The result is a format - that accepts arguments from [f1], then arguments from [f2]. *) +(** [f1 ^^ f2] catenates format strings [f1] and [f2]. The result is a + format string that behaves as the concatenation of format strings [f1] and + [f2]: in case of formatted output, it accepts arguments from [f1], then + arguments from [f2]; in case of formatted input, it returns results from + [f1], then results from [f2]. +*) (** {6 Program termination} *) @@ -918,13 +992,12 @@ termination time. The functions registered with [at_exit] will be called when the program executes {!Pervasives.exit}, or terminates, either normally or because of an uncaught exception. - The functions are called in ``last in, first out'' order: + The functions are called in 'last in, first out' order: the function most recently added with [at_exit] is called first. *) (**/**) - -(** {6 For system use only, not for the casual user} *) +(* The following is for system use only. Do not call directly. *) val valid_float_lexem : string -> string --- obrowser-1.1.1-old/rt/caml/pervasives.ml 2013-06-20 13:50:19.000000000 +0200 +++ obrowser-1.1.1/rt/caml/pervasives.ml 2013-06-20 13:51:53.000000000 +0200 @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: pervasives.ml 9412 2009-11-09 11:42:39Z weis $ *) - (* type 'a option = None | Some of 'a *) (* Exceptions *) @@ -24,66 +22,70 @@ exception Exit +(* Composition operators *) + +external ( |> ) : 'a -> ('a -> 'b) -> 'b = "%revapply" +external ( @@ ) : ('a -> 'b) -> 'a -> 'b = "%apply" + (* Comparisons *) -external (=) : 'a -> 'a -> bool = "%equal" -external (<>) : 'a -> 'a -> bool = "%notequal" -external (<) : 'a -> 'a -> bool = "%lessthan" -external (>) : 'a -> 'a -> bool = "%greaterthan" -external (<=) : 'a -> 'a -> bool = "%lessequal" -external (>=) : 'a -> 'a -> bool = "%greaterequal" -external compare: 'a -> 'a -> int = "%compare" +external ( = ) : 'a -> 'a -> bool = "%equal" +external ( <> ) : 'a -> 'a -> bool = "%notequal" +external ( < ) : 'a -> 'a -> bool = "%lessthan" +external ( > ) : 'a -> 'a -> bool = "%greaterthan" +external ( <= ) : 'a -> 'a -> bool = "%lessequal" +external ( >= ) : 'a -> 'a -> bool = "%greaterequal" +external compare : 'a -> 'a -> int = "%compare" let min x y = if x <= y then x else y let max x y = if x >= y then x else y -external (==) : 'a -> 'a -> bool = "%eq" -external (!=) : 'a -> 'a -> bool = "%noteq" +external ( == ) : 'a -> 'a -> bool = "%eq" +external ( != ) : 'a -> 'a -> bool = "%noteq" (* Boolean operations *) external not : bool -> bool = "%boolnot" -external (&) : bool -> bool -> bool = "%sequand" -external (&&) : bool -> bool -> bool = "%sequand" -external (or) : bool -> bool -> bool = "%sequor" -external (||) : bool -> bool -> bool = "%sequor" +external ( & ) : bool -> bool -> bool = "%sequand" +external ( && ) : bool -> bool -> bool = "%sequand" +external ( or ) : bool -> bool -> bool = "%sequor" +external ( || ) : bool -> bool -> bool = "%sequor" (* Integer operations *) -external (~-) : int -> int = "%negint" -external (~+) : int -> int = "%identity" +external ( ~- ) : int -> int = "%negint" +external ( ~+ ) : int -> int = "%identity" external succ : int -> int = "%succint" external pred : int -> int = "%predint" -external (+) : int -> int -> int = "%addint" -external (-) : int -> int -> int = "%subint" -external ( * ) : int -> int -> int = "%mulint" -external (/) : int -> int -> int = "%divint" -external (mod) : int -> int -> int = "%modint" +external ( + ) : int -> int -> int = "%addint" +external ( - ) : int -> int -> int = "%subint" +external ( * ) : int -> int -> int = "%mulint" +external ( / ) : int -> int -> int = "%divint" +external ( mod ) : int -> int -> int = "%modint" let abs x = if x >= 0 then x else -x -external (land) : int -> int -> int = "%andint" -external (lor) : int -> int -> int = "%orint" -external (lxor) : int -> int -> int = "%xorint" +external ( land ) : int -> int -> int = "%andint" +external ( lor ) : int -> int -> int = "%orint" +external ( lxor ) : int -> int -> int = "%xorint" let lnot x = x lxor (-1) -external (lsl) : int -> int -> int = "%lslint" -external (lsr) : int -> int -> int = "%lsrint" -external (asr) : int -> int -> int = "%asrint" +external ( lsl ) : int -> int -> int = "%lslint" +external ( lsr ) : int -> int -> int = "%lsrint" +external ( asr ) : int -> int -> int = "%asrint" -let min_int = 1 lsl (if 1 lsl 32 = 1 then 31 else 63) (* obrowser mod: no tag bit*) +let min_int = 1 lsl (if 1 lsl 31 = 0 then 30 else 62) let max_int = min_int - 1 - (* Floating-point operations *) -external (~-.) : float -> float = "%negfloat" -external (~+.) : float -> float = "%identity" -external (+.) : float -> float -> float = "%addfloat" -external (-.) : float -> float -> float = "%subfloat" +external ( ~-. ) : float -> float = "%negfloat" +external ( ~+. ) : float -> float = "%identity" +external ( +. ) : float -> float -> float = "%addfloat" +external ( -. ) : float -> float -> float = "%subfloat" external ( *. ) : float -> float -> float = "%mulfloat" -external (/.) : float -> float -> float = "%divfloat" +external ( /. ) : float -> float -> float = "%divfloat" external ( ** ) : float -> float -> float = "caml_power_float" "pow" "float" external exp : float -> float = "caml_exp_float" "exp" "float" external expm1 : float -> float = "caml_expm1_float" "caml_expm1" "float" @@ -136,16 +138,16 @@ | FP_zero | FP_infinite | FP_nan -external classify_float: float -> fpclass = "caml_classify_float" +external classify_float : float -> fpclass = "caml_classify_float" (* String operations -- more in module String *) external string_length : string -> int = "%string_length" -external string_create: int -> string = "caml_create_string" +external string_create : int -> string = "caml_create_string" external string_blit : string -> int -> string -> int -> int -> unit = "caml_blit_string" "noalloc" -let (^) s1 s2 = +let ( ^ ) s1 s2 = let l1 = string_length s1 and l2 = string_length s2 in let s = string_create (l1 + l2) in string_blit s1 0 s 0 l1; @@ -170,8 +172,8 @@ (* String conversion functions *) -external format_int: string -> int -> string = "caml_format_int" -external format_float: string -> float -> string = "caml_format_float" +external format_int : string -> int -> string = "caml_format_int" +external format_float : string -> float -> string = "caml_format_float" let string_of_bool b = if b then "true" else "false" @@ -187,7 +189,6 @@ module String = struct external get : string -> int -> char = "%string_safe_get" - external set : string -> int -> char -> unit = "%string_safe_set" end let valid_float_lexem s = @@ -195,7 +196,7 @@ let rec loop i = if i >= l then s ^ "." else match s.[i] with - | '0' .. '9' | '-' -> loop (i+1) + | '0' .. '9' | '-' -> loop (i + 1) | _ -> s in loop 0 @@ -207,7 +208,7 @@ (* List operations -- more in module List *) -let rec (@) l1 l2 = +let rec ( @ ) l1 l2 = match l1 with [] -> l2 | hd :: tl -> hd :: (tl @ l2) @@ -217,12 +218,13 @@ type in_channel type out_channel -let open_descriptor_out _ = failwith "not implemented in obrowser" -let open_descriptor_in _ = failwith "not implemented in obrowser" - -let stdin = Obj.magic 0 -let stdout = Obj.magic 0 -let stderr = Obj.magic 0 +external open_descriptor_out : int -> out_channel + = "caml_ml_open_descriptor_out" +external open_descriptor_in : int -> in_channel = "caml_ml_open_descriptor_in" + +let stdin = open_descriptor_in 0 +let stdout = open_descriptor_out 1 +let stderr = open_descriptor_out 2 (* General output functions *) @@ -231,103 +233,184 @@ | Open_creat | Open_trunc | Open_excl | Open_binary | Open_text | Open_nonblock -let open_desc _ _ _ = failwith "not implemented in obrowser" -let open_out_gen mode perm name = failwith "not implemented in obrowser" -let open_out name = failwith "not implemented in obrowser" -let open_out_bin name = failwith "not implemented in obrowser" -let flush _ = failwith "not implemented in obrowser" -let out_channels_list _ = failwith "not implemented in obrowser" -let flush_all () = failwith "not implemented in obrowser" -let unsafe_output _ _ _ _ = failwith "not implemented in obrowser" -let output_char _ _ = failwith "not implemented in obrowser" -let output_string oc s = failwith "not implemented in obrowser" -let output oc s ofs len = failwith "not implemented in obrowser" -let output_byte _ _ = failwith "not implemented in obrowser" -let output_binary_int _ _ = failwith "not implemented in obrowser" -let marshal_to_channel _ _ _ = failwith "not implemented in obrowser" -let output_value _ _ = failwith "not implemented in obrowser" -let seek_out _ _ = failwith "not implemented in obrowser" -let pos_out _ = failwith "not implemented in obrowser" -let out_channel_length _ = failwith "not implemented in obrowser" -let close_out_channel _ = failwith "not implemented in obrowser" -let close_out _ = failwith "not implemented in obrowser" -let close_out_noerr _ = failwith "not implemented in obrowser" -let set_binary_mode_out _ _ = failwith "not implemented in obrowser" +external open_desc : string -> open_flag list -> int -> int = "caml_sys_open" + +let open_out_gen mode perm name = + open_descriptor_out(open_desc name mode perm) + +let open_out name = + open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_text] 0o666 name + +let open_out_bin name = + open_out_gen [Open_wronly; Open_creat; Open_trunc; Open_binary] 0o666 name + +external flush : out_channel -> unit = "caml_ml_flush" + +external out_channels_list : unit -> out_channel list + = "caml_ml_out_channels_list" + +let flush_all () = + let rec iter = function + [] -> () + | a :: l -> (try flush a with _ -> ()); iter l + in iter (out_channels_list ()) + +external unsafe_output : out_channel -> string -> int -> int -> unit + = "caml_ml_output" + +external output_char : out_channel -> char -> unit = "caml_ml_output_char" + +let output_string oc s = + unsafe_output oc s 0 (string_length s) + +let output oc s ofs len = + if ofs < 0 || len < 0 || ofs > string_length s - len + then invalid_arg "output" + else unsafe_output oc s ofs len + +external output_byte : out_channel -> int -> unit = "caml_ml_output_char" +external output_binary_int : out_channel -> int -> unit = "caml_ml_output_int" + +external marshal_to_channel : out_channel -> 'a -> unit list -> unit + = "caml_output_value" +let output_value chan v = marshal_to_channel chan v [] + +external seek_out : out_channel -> int -> unit = "caml_ml_seek_out" +external pos_out : out_channel -> int = "caml_ml_pos_out" +external out_channel_length : out_channel -> int = "caml_ml_channel_size" +external close_out_channel : out_channel -> unit = "caml_ml_close_channel" +let close_out oc = flush oc; close_out_channel oc +let close_out_noerr oc = + (try flush oc with _ -> ()); + (try close_out_channel oc with _ -> ()) +external set_binary_mode_out : out_channel -> bool -> unit + = "caml_ml_set_binary_mode" (* General input functions *) -let open_in_gen _ _ _ = failwith "not implemented in obrowser" -let open_in _ = failwith "not implemented in obrowser" -let open_in_bin _ = failwith "not implemented in obrowser" -let input_char _ = failwith "not implemented in obrowser" -let unsafe_input _ _ _ _ = failwith "not implemented in obrowser" -let input _ _ _ _ = failwith "not implemented in obrowser" -let rec unsafe_really_input _ _ _ _ = failwith "not implemented in obrowser" -let really_input _ _ _ _ = failwith "not implemented in obrowser" -let input_scan_line _ = failwith "not implemented in obrowser" -let input_line _ = failwith "not implemented in obrowser" - -let input_byte _ = failwith "not implemented in obrowser" -let input_binary_int _ = failwith "not implemented in obrowser" -let input_value _ = failwith "not implemented in obrowser" -let seek_in _ _ = failwith "not implemented in obrowser" -let pos_in _ = failwith "not implemented in obrowser" -let in_channel_length _ = failwith "not implemented in obrowser" -let close_in _ = failwith "not implemented in obrowser" -let close_in_noerr _ = failwith "not implemented in obrowser" -let set_binary_mode_in _ _ = failwith "not implemented in obrowser" +let open_in_gen mode perm name = + open_descriptor_in(open_desc name mode perm) -(* Output functions on standard output *) +let open_in name = + open_in_gen [Open_rdonly; Open_text] 0 name + +let open_in_bin name = + open_in_gen [Open_rdonly; Open_binary] 0 name + +external input_char : in_channel -> char = "caml_ml_input_char" + +external unsafe_input : in_channel -> string -> int -> int -> int + = "caml_ml_input" + +let input ic s ofs len = + if ofs < 0 || len < 0 || ofs > string_length s - len + then invalid_arg "input" + else unsafe_input ic s ofs len + +let rec unsafe_really_input ic s ofs len = + if len <= 0 then () else begin + let r = unsafe_input ic s ofs len in + if r = 0 + then raise End_of_file + else unsafe_really_input ic s (ofs + r) (len - r) + end -external basic_io_write : string -> unit = "caml_basic_io_write" +let really_input ic s ofs len = + if ofs < 0 || len < 0 || ofs > string_length s - len + then invalid_arg "really_input" + else unsafe_really_input ic s ofs len + +external input_scan_line : in_channel -> int = "caml_ml_input_scan_line" + +let input_line chan = + let rec build_result buf pos = function + [] -> buf + | hd :: tl -> + let len = string_length hd in + string_blit hd 0 buf (pos - len) len; + build_result buf (pos - len) tl in + let rec scan accu len = + let n = input_scan_line chan in + if n = 0 then begin (* n = 0: we are at EOF *) + match accu with + [] -> raise End_of_file + | _ -> build_result (string_create len) len accu + end else if n > 0 then begin (* n > 0: newline found in buffer *) + let res = string_create (n - 1) in + ignore (unsafe_input chan res 0 (n - 1)); + ignore (input_char chan); (* skip the newline *) + match accu with + [] -> res + | _ -> let len = len + n - 1 in + build_result (string_create len) len (res :: accu) + end else begin (* n < 0: newline not found *) + let beg = string_create (-n) in + ignore(unsafe_input chan beg 0 (-n)); + scan (beg :: accu) (len - n) + end + in scan [] 0 + +external input_byte : in_channel -> int = "caml_ml_input_char" +external input_binary_int : in_channel -> int = "caml_ml_input_int" +external input_value : in_channel -> 'a = "caml_input_value" +external seek_in : in_channel -> int -> unit = "caml_ml_seek_in" +external pos_in : in_channel -> int = "caml_ml_pos_in" +external in_channel_length : in_channel -> int = "caml_ml_channel_size" +external close_in : in_channel -> unit = "caml_ml_close_channel" +let close_in_noerr ic = (try close_in ic with _ -> ());; +external set_binary_mode_in : in_channel -> bool -> unit + = "caml_ml_set_binary_mode" -let print_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s) -let print_string s = basic_io_write s -let print_int i = basic_io_write (string_of_int i) -let print_float f = basic_io_write (string_of_float f) +(* Output functions on standard output *) + +let print_char c = output_char stdout c +let print_string s = output_string stdout s +let print_int i = output_string stdout (string_of_int i) +let print_float f = output_string stdout (string_of_float f) let print_endline s = - print_string s; print_char '\n' -let print_newline () = print_char '\n' + output_string stdout s; output_char stdout '\n'; flush stdout +let print_newline () = output_char stdout '\n'; flush stdout (* Output functions on standard error *) -let prerr_char c = basic_io_write (let s = string_create 1 in s.[0] <- c ; s) -let prerr_string s = basic_io_write s -let prerr_int i = basic_io_write (string_of_int i) -let prerr_float f = basic_io_write (string_of_float f) +let prerr_char c = output_char stderr c +let prerr_string s = output_string stderr s +let prerr_int i = output_string stderr (string_of_int i) +let prerr_float f = output_string stderr (string_of_float f) let prerr_endline s = - prerr_string s; prerr_char '\n' -let prerr_newline () = prerr_char '\n' + output_string stderr s; output_char stderr '\n'; flush stderr +let prerr_newline () = output_char stderr '\n'; flush stderr (* Input functions on standard input *) -let read_line () = failwith "not implemented in obrowser" -let read_int () = failwith "not implemented in obrowser" -let read_float () = failwith "not implemented in obrowser" +let read_line () = flush stdout; input_line stdin +let read_int () = int_of_string(read_line()) +let read_float () = float_of_string(read_line()) (* Operations on large files *) module LargeFile = struct - let seek_out _ _ = failwith "not implemented in obrowser" - let pos_out _ = failwith "not implemented in obrowser" - let out_channel_length _ = failwith "not implemented in obrowser" - let seek_in _ _ = failwith "not implemented in obrowser" - let pos_in _ = failwith "not implemented in obrowser" - let in_channel_length _ = failwith "not implemented in obrowser" + external seek_out : out_channel -> int64 -> unit = "caml_ml_seek_out_64" + external pos_out : out_channel -> int64 = "caml_ml_pos_out_64" + external out_channel_length : out_channel -> int64 + = "caml_ml_channel_size_64" + external seek_in : in_channel -> int64 -> unit = "caml_ml_seek_in_64" + external pos_in : in_channel -> int64 = "caml_ml_pos_in_64" + external in_channel_length : in_channel -> int64 = "caml_ml_channel_size_64" end (* References *) -type 'a ref = { mutable contents: 'a } -external ref: 'a -> 'a ref = "%makemutable" -external (!): 'a ref -> 'a = "%field0" -external (:=): 'a ref -> 'a -> unit = "%setfield0" -external incr: int ref -> unit = "%incr" -external decr: int ref -> unit = "%decr" +type 'a ref = { mutable contents : 'a } +external ref : 'a -> 'a ref = "%makemutable" +external ( ! ) : 'a ref -> 'a = "%field0" +external ( := ) : 'a ref -> 'a -> unit = "%setfield0" +external incr : int ref -> unit = "%incr" +external decr : int ref -> unit = "%decr" (* Formats *) -type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 +type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'c, 'c, 'd) format6 type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 @@ -345,7 +428,8 @@ ('f, 'b, 'c, 'e, 'g, 'h) format6 -> ('a, 'b, 'c, 'd, 'g, 'h) format6) = fun fmt1 fmt2 -> - string_to_format (format_to_string fmt1 ^ format_to_string fmt2);; + string_to_format (format_to_string fmt1 ^ "%," ^ format_to_string fmt2) +;; let string_of_format fmt = let s = format_to_string fmt in @@ -358,7 +442,7 @@ external sys_exit : int -> 'a = "caml_sys_exit" -let exit_function = ref (fun () -> ()) +let exit_function = ref flush_all let at_exit f = let g = !exit_function in --- obrowser-1.1.1.orig/rt/caml/printexc.ml 2011-04-20 18:26:44.000000000 +0200 +++ obrowser-1.1.1/rt/caml/printexc.ml 2013-08-13 15:54:35.000000000 +0200 @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -11,8 +11,6 @@ (* *) (***********************************************************************) -(* $Id: printexc.ml 10272 2010-04-19 12:25:46Z frisch $ *) - open Printf;; let printers = ref [] @@ -56,9 +54,12 @@ sprintf locfmt file line char (char+5) "Pattern matching failed" | Assert_failure(file, line, char) -> sprintf locfmt file line char (char+6) "Assertion failed" + | Undefined_recursive_module(file, line, char) -> + sprintf locfmt file line char (char+6) "Undefined recursive module" | _ -> let x = Obj.repr x in - let constructor = (Obj.magic(Obj.field (Obj.field x 0) 0) : string) in + let constructor = + (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in constructor ^ (fields x) in conv !printers @@ -78,6 +79,11 @@ eprintf "Uncaught exception: %s\n" (to_string x); exit 2 +type raw_backtrace + +external get_raw_backtrace: + unit -> raw_backtrace = "caml_get_exception_raw_backtrace" + type loc_info = | Known_location of bool (* is_raise *) * string (* filename *) @@ -86,8 +92,13 @@ * int (* end char *) | Unknown_location of bool (*is_raise*) -external get_exception_backtrace: - unit -> loc_info array option = "caml_get_exception_backtrace" +(* to avoid warning *) +let _ = [Known_location (false, "", 0, 0, 0); Unknown_location false] + +type backtrace = loc_info array + +external convert_raw_backtrace: + raw_backtrace -> backtrace option = "caml_convert_raw_backtrace" let format_loc_info pos li = let is_raise = @@ -108,8 +119,8 @@ sprintf "%s unknown location" info -let print_backtrace outchan = - match get_exception_backtrace() with +let print_exception_backtrace outchan backtrace = + match backtrace with | None -> fprintf outchan "(Program not linked with -g, cannot print stack backtrace)\n" @@ -119,8 +130,15 @@ fprintf outchan "%s\n" (format_loc_info i a.(i)) done -let get_backtrace () = - match get_exception_backtrace() with +let print_raw_backtrace outchan raw_backtrace = + print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace) + +(* confusingly named: prints the global current backtrace *) +let print_backtrace outchan = + print_raw_backtrace outchan (get_raw_backtrace ()) + +let backtrace_to_string backtrace = + match backtrace with | None -> "(Program not linked with -g, cannot print stack backtrace)\n" | Some a -> @@ -131,8 +149,22 @@ done; Buffer.contents b +let raw_backtrace_to_string raw_backtrace = + backtrace_to_string (convert_raw_backtrace raw_backtrace) + +(* confusingly named: + returns the *string* corresponding to the global current backtrace *) +let get_backtrace () = + (* we could use the caml_get_exception_backtrace primitive here, but + we hope to deprecate it so it's better to just compose the + raw stuff *) + backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ())) + external record_backtrace: bool -> unit = "caml_record_backtrace" external backtrace_status: unit -> bool = "caml_backtrace_status" let register_printer fn = printers := fn :: !printers + + +external get_callstack: int -> raw_backtrace = "caml_get_current_callstack" --- obrowser-1.1.1.orig/rt/caml/printexc.mli 2011-04-20 18:26:44.000000000 +0200 +++ obrowser-1.1.1/rt/caml/printexc.mli 2013-08-13 15:54:40.000000000 +0200 @@ -1,6 +1,6 @@ (***********************************************************************) (* *) -(* Objective Caml *) +(* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) @@ -11,9 +11,7 @@ (* *) (***********************************************************************) -(* $Id: printexc.mli 10457 2010-05-21 18:30:12Z doligez $ *) - -(** Facilities for printing exceptions. *) +(** Facilities for printing exceptions and inspecting current call stack. *) val to_string: exn -> string (** [Printexc.to_string e] returns a string representation of @@ -77,5 +75,40 @@ in the reverse order of their registrations, until a printer returns a [Some s] value (if no such printer exists, the runtime will use a generic printer). + + When using this mechanism, one should be aware that an exception backtrace + is attached to the thread that saw it raised, rather than to the exception + itself. Practically, it means that the code related to [fn] should not use + the backtrace if it has itself raised an exception before. @since 3.11.2 *) + +(** {6 Raw backtraces} *) + +type raw_backtrace + +(** The abstract type [backtrace] stores exception backtraces in + a low-level format, instead of directly exposing them as string as + the [get_backtrace()] function does. + + This allows to pay the performance overhead of representation + conversion and formatting only at printing time, which is useful + if you want to record more backtrace than you actually print. +*) + +val get_raw_backtrace: unit -> raw_backtrace +val print_raw_backtrace: out_channel -> raw_backtrace -> unit +val raw_backtrace_to_string: raw_backtrace -> string + + +(** {6 Current call stack} *) + +val get_callstack: int -> raw_backtrace + +(** [Printexc.get_callstack n] returns a description of the top of the + call stack on the current program point (for the current thread), + with at most [n] entries. (Note: this function is not related to + exceptions at all, despite being part of the [Printexc] module.) + + @since 4.01.0 +*) --- obrowser-1.1.1/rt/caml/pervasives.mli 2013-11-27 09:51:32.000000000 +0100 +++ /usr/local/ocaml/trunk/lib/ocaml/pervasives.mli 2013-11-26 19:03:11.000000000 +0100 @@ -28,6 +28,11 @@ external raise : exn -> 'a = "%raise" (** Raise the given exception value *) +external raise_notrace : exn -> 'a = "%raise_notrace" +(** A faster version [raise] which does not record the backtrace. + @since 4.02.0 +*) + val invalid_arg : string -> 'a (** Raise exception [Invalid_argument] with the given string. *) --- obrowser-1.1.1/rt/caml/pervasives.ml 2013-11-27 14:25:40.000000000 +0100 +++ /usr/local/ocaml/trunk/lib/ocaml/pervasives.ml 2013-11-26 19:03:11.000000000 +0100 @@ -15,7 +15,17 @@ (* Exceptions *) +external register_named_value : string -> 'a -> unit + = "caml_register_named_value" + +let () = + (* for asmrun/fail.c *) + register_named_value "Pervasives.array_bound_error" + (Invalid_argument "index out of bounds") + + external raise : exn -> 'a = "%raise" +external raise_notrace : exn -> 'a = "%raise_notrace" let failwith s = raise(Failure s) let invalid_arg s = raise(Invalid_argument s) @@ -454,7 +464,4 @@ do_at_exit (); sys_exit retcode -external register_named_value : string -> 'a -> unit - = "caml_register_named_value" - let _ = register_named_value "Pervasives.do_at_exit" do_at_exit --- obrowser-1.1.1/rt/caml/printexc.mli 2013-11-27 14:26:19.000000000 +0100 +++ /usr/local/ocaml/trunk/lib/ocaml/printexc.mli 2013-11-26 19:03:11.000000000 +0100 @@ -112,3 +112,23 @@ @since 4.01.0 *) + + +(** {6 Exception slots} *) + +val exn_slot_id: exn -> int +(** [Printexc.exn_slot_id] returns an integer which uniquely identifies + the constructor used to create the exception value [exn] + (in the current runtime). + + @since 4.02.0 +*) + +val exn_slot_name: exn -> string +(** [Printexc.exn_slot_id exn] returns the internal name of the constructor + used to create the exception value [exn]. + + @since 4.02.0 +*) + + --- obrowser-1.1.1/rt/caml/printexc.ml 2013-11-27 14:27:37.000000000 +0100 +++ /usr/local/ocaml/trunk/lib/ocaml/printexc.ml 2013-11-26 19:03:11.000000000 +0100 @@ -58,9 +58,12 @@ sprintf locfmt file line char (char+6) "Undefined recursive module" | _ -> let x = Obj.repr x in - let constructor = - (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in - constructor ^ (fields x) in + if Obj.tag x <> 0 then + (Obj.magic (Obj.field x 0) : string) + else + let constructor = + (Obj.magic (Obj.field (Obj.field x 0) 0) : string) in + constructor ^ (fields x) in conv !printers let print fct arg = @@ -168,3 +171,16 @@ external get_callstack: int -> raw_backtrace = "caml_get_current_callstack" + + +let exn_slot x = + let x = Obj.repr x in + if Obj.tag x = 0 then Obj.field x 0 else x + +let exn_slot_id x = + let slot = exn_slot x in + (Obj.obj (Obj.field slot 1) : int) + +let exn_slot_name x = + let slot = exn_slot x in + (Obj.obj (Obj.field slot 0) : string) --- obrowser-1.1.1/rt/caml/list.mli 2013-11-27 14:28:14.000000000 +0100 +++ /usr/local/ocaml/trunk/lib/ocaml/list.mli 2013-11-26 19:03:11.000000000 +0100 @@ -280,6 +278,9 @@ (** Same as {!List.sort} or {!List.stable_sort}, whichever is faster on typical input. *) +val sort_uniq : ('a -> 'a -> int) -> 'a list -> 'a list +(** Same as {!List.sort}, but also remove duplicates. *) + val merge : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list (** Merge two lists: Assuming that [l1] and [l2] are sorted according to the --- obrowser-1.1.1/rt/caml/list.ml 2013-11-27 14:29:31.000000000 +0100 +++ /usr/local/ocaml/trunk/lib/ocaml/list.ml 2013-11-26 19:03:11.000000000 +0100 @@ -326,3 +324,106 @@ array_to_list_in_place a ;; *) + + +(** sorting + removing duplicates *) + +let sort_uniq cmp l = + let rec rev_merge l1 l2 accu = + match l1, l2 with + | [], l2 -> rev_append l2 accu + | l1, [] -> rev_append l1 accu + | h1::t1, h2::t2 -> + let c = cmp h1 h2 in + if c = 0 then rev_merge t1 t2 (h1::accu) + else if c < 0 + then rev_merge t1 l2 (h1::accu) + else rev_merge l1 t2 (h2::accu) + in + let rec rev_merge_rev l1 l2 accu = + match l1, l2 with + | [], l2 -> rev_append l2 accu + | l1, [] -> rev_append l1 accu + | h1::t1, h2::t2 -> + let c = cmp h1 h2 in + if c = 0 then rev_merge_rev t1 t2 (h1::accu) + else if c > 0 + then rev_merge_rev t1 l2 (h1::accu) + else rev_merge_rev l1 t2 (h2::accu) + in + let rec sort n l = + match n, l with + | 2, x1 :: x2 :: _ -> + let c = cmp x1 x2 in + if c = 0 then [x1] + else if c < 0 then [x1; x2] else [x2; x1] + | 3, x1 :: x2 :: x3 :: _ -> + let c = cmp x1 x2 in + if c = 0 then begin + let c = cmp x2 x3 in + if c = 0 then [x2] + else if c < 0 then [x2; x3] else [x3; x2] + end else if c < 0 then begin + let c = cmp x2 x3 in + if c = 0 then [x1; x2] + else if c < 0 then [x1; x2; x3] + else let c = cmp x1 x3 in + if c = 0 then [x1; x2] + else if c < 0 then [x1; x3; x2] + else [x3; x1; x2] + end else begin + let c = cmp x1 x3 in + if c = 0 then [x2; x1] + else if c < 0 then [x2; x1; x3] + else let c = cmp x2 x3 in + if c = 0 then [x2; x1] + else if c < 0 then [x2; x3; x1] + else [x3; x2; x1] + end + | n, l -> + let n1 = n asr 1 in + let n2 = n - n1 in + let l2 = chop n1 l in + let s1 = rev_sort n1 l in + let s2 = rev_sort n2 l2 in + rev_merge_rev s1 s2 [] + and rev_sort n l = + match n, l with + | 2, x1 :: x2 :: _ -> + let c = cmp x1 x2 in + if c = 0 then [x1] + else if c > 0 then [x1; x2] else [x2; x1] + | 3, x1 :: x2 :: x3 :: _ -> + let c = cmp x1 x2 in + if c = 0 then begin + let c = cmp x2 x3 in + if c = 0 then [x2] + else if c > 0 then [x2; x3] else [x3; x2] + end else if c > 0 then begin + let c = cmp x2 x3 in + if c = 0 then [x1; x2] + else if c > 0 then [x1; x2; x3] + else let c = cmp x1 x3 in + if c = 0 then [x1; x2] + else if c > 0 then [x1; x3; x2] + else [x3; x1; x2] + end else begin + let c = cmp x1 x3 in + if c = 0 then [x2; x1] + else if c > 0 then [x2; x1; x3] + else let c = cmp x2 x3 in + if c = 0 then [x2; x1] + else if c > 0 then [x2; x3; x1] + else [x3; x2; x1] + end + | n, l -> + let n1 = n asr 1 in + let n2 = n - n1 in + let l2 = chop n1 l in + let s1 = sort n1 l in + let s2 = sort n2 l2 in + rev_merge s1 s2 [] + in + let len = length l in + if len < 2 then l else sort len l +;;