Imported Upstream snapshot 8.3~beta0+13298

1 files changed, 362 insertions, 442 deletions

diff --git a/lib/util.ml b/lib/util.ml
index 0d6e7ff2..6d04c3c2 100644
--- a/lib/util.ml
+++ b/lib/util.ml
@@ -6,7 +6,7 @@
 (*         *       GNU Lesser General Public License Version 2.1       *)
 (***********************************************************************)
 
-(* $Id: util.ml 13200 2010-06-25 22:36:25Z letouzey $ *)
+(* $Id$ *)
 
 open Pp
 
@@ -20,8 +20,15 @@ exception UserError of string * std_ppcmds (* User errors *)
 let error string = raise (UserError(string, str string))
 let errorlabstrm l pps = raise (UserError(l,pps))
 
+exception AnomalyOnError of string * exn
+
+exception AlreadyDeclared of std_ppcmds (* for already declared Schemes *)
+let alreadydeclared pps = raise (AlreadyDeclared(pps))
+
 let todo s = prerr_string ("TODO: "^s^"\n")
 
+exception Timeout
+
 type loc = Compat.loc
 let dummy_loc = Compat.dummy_loc
 let unloc = Compat.unloc
@@ -34,7 +41,7 @@ let anomaly_loc (loc,s,strm) = Stdpp.raise_with_loc loc (Anomaly (s,strm))
 let user_err_loc (loc,s,strm) = Stdpp.raise_with_loc loc (UserError (s,strm))
 let invalid_arg_loc (loc,s) = Stdpp.raise_with_loc loc (Invalid_argument s)
 
-let located_fold_left f x (_,a) = f x a 
+let located_fold_left f x (_,a) = f x a
 let located_iter2 f (_,a) (_,b) = f a b
 
 (* Like Exc_located, but specifies the outermost file read, the filename
@@ -47,6 +54,12 @@ exception Error_in_file of string * (bool * string * loc) * exn
 let on_fst f (a,b) = (f a,b)
 let on_snd f (a,b) = (a,f b)
 
+(* Mapping under pairs *)
+
+let on_pi1 f (a,b,c) = (f a,b,c)
+let on_pi2 f (a,b,c) = (a,f b,c)
+let on_pi3 f (a,b,c) = (a,b,f c)
+
 (* Projections from triplets *)
 
 let pi1 (a,_,_) = a
@@ -65,13 +78,13 @@ let is_blank = function
 
 (* Strings *)
 
-let explode s = 
+let explode s =
   let rec explode_rec n =
     if n >= String.length s then
       []
-    else 
+    else
       String.make 1 (String.get s n) :: explode_rec (succ n)
-  in 
+  in
   explode_rec 0
 
 let implode sl = String.concat "" sl
@@ -91,16 +104,20 @@ let strip s =
   let a = lstrip_rec 0 and b = rstrip_rec (n-1) in
   String.sub s a (b-a+1)
 
+let drop_simple_quotes s =
+  let n = String.length s in
+  if n > 2 & s.[0] = '\'' & s.[n-1] = '\'' then String.sub s 1 (n-2) else s
+
 (* substring searching... *)
 
 (* gdzie = where, co = what *)
 (* gdzie=gdzie(string) gl=gdzie(length) gi=gdzie(index) *)
-let rec is_sub gdzie gl gi co cl ci = 
+let rec is_sub gdzie gl gi co cl ci =
   (ci>=cl) ||
-  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) && 
+  ((String.unsafe_get gdzie gi = String.unsafe_get co ci) &&
    (is_sub gdzie gl (gi+1) co cl (ci+1)))
 
-let rec raw_str_index i gdzie l c co cl = 
+let rec raw_str_index i gdzie l c co cl =
   (* First adapt to ocaml 3.11 new semantics of index_from *)
   if (i+cl > l) then raise Not_found;
   (* Then proceed as in ocaml < 3.11 *)
@@ -108,7 +125,7 @@ let rec raw_str_index i gdzie l c co cl =
     if (i'+cl <= l) && (is_sub gdzie l i' co cl 0) then i' else
       raw_str_index (i'+1) gdzie l c co cl
 
-let string_index_from gdzie i co = 
+let string_index_from gdzie i co =
   if co="" then i else
     raw_str_index i gdzie (String.length gdzie)
       (String.unsafe_get co 0) co (String.length co)
@@ -130,7 +147,7 @@ let ordinal n =
 let split_string_at c s =
   let len = String.length s in
   let rec split n =
-    try  
+    try
       let pos = String.index_from s n c in
       let dir = String.sub s n (pos-n) in
       dir :: split (succ pos)
@@ -153,138 +170,105 @@ type utf8_status = UnicodeLetter | UnicodeIdentPart | UnicodeSymbol
 
 exception UnsupportedUtf8
 
-let classify_unicode unicode =
-    match unicode land 0x1F000 with
-    | 0x0 ->
-    begin match unicode with
-    (* utf-8 Basic Latin underscore *)
-    | x when x = 0x005F -> UnicodeLetter
-    (* utf-8 Basic Latin letters *)
-    | x when 0x0041 <= x & x <= 0x005A -> UnicodeLetter
-    | x when 0x0061 <= x & x <= 0x007A -> UnicodeLetter
-    (* utf-8 Basic Latin digits and quote *)
-    | x when 0x0030 <= x & x <= 0x0039 or x = 0x0027 -> UnicodeIdentPart
-    (* utf-8 Basic Latin symbols *)
-    | x when x <= 0x007F -> UnicodeSymbol
-    (* utf-8 Latin-1 non breaking space U00A0 *)
-    | 0x00A0 -> UnicodeLetter
-    (* utf-8 Latin-1 symbols U00A1-00BF *)
-    | x when 0x00A0 <= x & x <= 0x00BF -> UnicodeSymbol
-    (* utf-8 Latin-1 letters U00C0-00D6 *)
-    | x when 0x00C0 <= x & x <= 0x00D6 -> UnicodeLetter
-    (* utf-8 Latin-1 symbol U00D7 *)
-    | 0x00D7 -> UnicodeSymbol
-    (* utf-8 Latin-1 letters U00D8-00F6 *)
-    | x when 0x00D8 <= x & x <= 0x00F6 -> UnicodeLetter
-    (* utf-8 Latin-1 symbol U00F7 *)
-    | 0x00F7 -> UnicodeSymbol
-    (* utf-8 Latin-1 letters U00F8-00FF *)
-    | x when 0x00F8 <= x & x <= 0x00FF -> UnicodeLetter
-    (* utf-8 Latin Extended A U0100-017F and Latin Extended B U0180-U0241 *)
-    | x when 0x0100 <= x & x <= 0x0241 -> UnicodeLetter
-    (* utf-8 Phonetic letters U0250-02AF *)
-    | x when 0x0250 <= x & x <= 0x02AF -> UnicodeLetter
-    (* utf-8 what do to with diacritics U0300-U036F ? *)
-    (* utf-8 Greek letters U0380-03FF *)
-    | x when 0x0380 <= x & x <= 0x03FF -> UnicodeLetter
-    (* utf-8 Cyrillic letters U0400-0481 *)
-    | x when 0x0400 <= x & x <= 0x0481 -> UnicodeLetter
-    (* utf-8 Cyrillic symbol U0482 *)
-    | 0x0482 -> UnicodeSymbol
-    (* utf-8 what do to with diacritics U0483-U0489 \ U0487 ? *)
-    (* utf-8 Cyrillic letters U048A-U4F9 (Warning: 04CF) *)
-    | x when 0x048A <= x & x <= 0x04F9 -> UnicodeLetter
-    (* utf-8 Cyrillic supplement letters U0500-U050F *)
-    | x when 0x0500 <= x & x <= 0x050F -> UnicodeLetter
-    (* utf-8 Hebrew letters U05D0-05EA *)
-    | x when 0x05D0 <= x & x <= 0x05EA -> UnicodeLetter
-    (* utf-8 Arabic letters U0621-064A *)
-    | x when 0x0621 <= x & x <= 0x064A -> UnicodeLetter
-    (* utf-8 Arabic supplement letters U0750-076D *)
-    | x when 0x0750 <= x & x <= 0x076D -> UnicodeLetter
-    | _ -> raise UnsupportedUtf8
-    end
-    | 0x1000 ->
-    begin match unicode with
-    (* utf-8 Georgian U10A0-10FF (has holes) *)
-    | x when 0x10A0 <= x & x <= 0x10FF -> UnicodeLetter
-    (* utf-8 Hangul Jamo U1100-11FF (has holes) *)
-    | x when 0x1100 <= x & x <= 0x11FF -> UnicodeLetter
-    (* utf-8 Latin additional letters U1E00-1E9B and U1EA0-1EF9 *)
-    | x when 0x1E00 <= x & x <= 0x1E9B -> UnicodeLetter
-    | x when 0x1EA0 <= x & x <= 0x1EF9 -> UnicodeLetter
-    | _ -> raise UnsupportedUtf8
-    end
-    | 0x2000 ->
-    begin match unicode with
-    (* utf-8 general punctuation U2080-2089 *)
-    (* Hyphens *)
-    | x when 0x2010 <= x & x <= 0x2011 -> UnicodeLetter 
-    (* Dashes and other symbols *)
-    | x when 0x2012 <= x & x <= 0x2027 -> UnicodeSymbol
-    (* Per mille and per ten thousand signs *)
-    | x when 0x2030 <= x & x <= 0x2031 -> UnicodeSymbol
-    (* Prime letters *)
-    | x when 0x2032 <= x & x <= 0x2034 or x = 0x2057 -> UnicodeIdentPart
-    (* Miscellaneous punctuation *)
-    | x when 0x2039 <= x & x <= 0x2056 -> UnicodeSymbol
-    | x when 0x2058 <= x & x <= 0x205E -> UnicodeSymbol
-    (* Invisible mathematical operators *)
-    | x when 0x2061 <= x & x <= 0x2063 -> UnicodeSymbol
-    (* utf-8 superscript U2070-207C *) 
-    | x when 0x2070 <= x & x <= 0x207C -> UnicodeSymbol
-    (* utf-8 subscript U2080-2089 *) 
-    | x when 0x2080 <= x & x <= 0x2089 -> UnicodeIdentPart
-    (* utf-8 letter-like U2100-214F *)
-    | x when 0x2100 <= x & x <= 0x214F -> UnicodeLetter
-    (* utf-8 number-forms U2153-2183 *)
-    | x when 0x2153 <= x & x <= 0x2183 -> UnicodeSymbol
-    (* utf-8 arrows A U2190-21FF *)
-    (* utf-8 mathematical operators U2200-22FF *)
-    (* utf-8 miscellaneous technical U2300-23FF *)
-    | x when 0x2190 <= x & x <= 0x23FF -> UnicodeSymbol
-    (* utf-8 box drawing U2500-257F has ceiling, etc. *)
-    (* utf-8 block elements U2580-259F *)
-    (* utf-8 geom. shapes U25A0-25FF (has triangles, losange, etc) *)
-    (* utf-8 miscellaneous symbols U2600-26FF *)
-    | x when 0x2500 <= x & x <= 0x26FF -> UnicodeSymbol
-    (* utf-8 arrows B U2900-297F *)
-    | x when 0x2900 <= x & x <= 0x297F -> UnicodeSymbol
-    (* utf-8 mathematical operators U2A00-2AFF *)
-    | x when 0x2A00 <= x & x <= 0x2AFF -> UnicodeSymbol
-    (* utf-8 bold symbols U2768-U2775 *)
-    | x when 0x2768 <= x & x <= 0x2775 -> UnicodeSymbol
-    (* utf-8 arrows and brackets U27E0-U27FF *)
-    | x when 0x27E0 <= x & x <= 0x27FF -> UnicodeSymbol
-    (* utf-8 brackets, braces and parentheses *)
-    | x when 0x2980 <= x & x <= 0x29FF -> UnicodeSymbol
-    (* utf-8 miscellaneous including double-plus U29F0-U29FF *)
-    | x when 0x29F0 <= x & x <= 0x29FF -> UnicodeSymbol
-    | _ -> raise UnsupportedUtf8
-    end
-    | _ ->
-    begin match unicode with
-    (* utf-8 CJC Symbols and Punctuation  *)
-    | x when 0x3008 <= x & x <= 0x3020 -> UnicodeSymbol
-    (* utf-8 Hiragana U3040-309F and Katakana U30A0-30FF *)
-    | x when 0x3040 <= x & x <= 0x30FF -> UnicodeLetter
-    (* utf-8 Unified CJK Ideographs U4E00-9FA5 *)
-    | x when 0x4E00 <= x & x <= 0x9FA5 -> UnicodeLetter
-    (* utf-8 Hangul syllables UAC00-D7AF *)
-    | x when 0xAC00 <= x & x <= 0xD7AF -> UnicodeLetter
-    (* utf-8 Gothic U10330-1034A *)
-    | x when 0x10330 <= x & x <= 0x1034A -> UnicodeLetter
-    (* utf-8 Math Alphanumeric Symbols U1D400-1D7FF (letters) (has holes) *)
-    | x when 0x1D400 <= x & x <= 0x1D7CB -> UnicodeLetter
-    (* utf-8 Math Alphanumeric Symbols U1D400-1D7FF (digits) *)
-    | x when 0x1D7CE <= x & x <= 0x1D7FF -> UnicodeIdentPart
-    | _ -> raise UnsupportedUtf8
-    end
+(* The following table stores classes of Unicode characters that
+   are used by the lexer. There are 3 different classes so 2 bits are
+   allocated for each character. We only use 16 bits over the 31 bits
+   to simplify the masking process. (This choice seems to be a good
+   trade-off between speed and space after some benchmarks.) *)
+
+(* A 256ko table, initially filled with zeros. *)
+let table = Array.create (1 lsl 17) 0
+
+(* Associate a 2-bit pattern to each status at position [i]. 
+   Only the 3 lowest bits of [i] are taken into account to 
+   define the position of the pattern in the word. 
+   Notice that pattern "00" means "undefined". *)
+let mask i = function
+  | UnicodeLetter    -> 1 lsl ((i land 7) lsl 1) (* 01 *)
+  | UnicodeIdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *)
+  | UnicodeSymbol    -> 3 lsl ((i land 7) lsl 1) (* 11 *)
+
+(* Helper to reset 2 bits in a word. *)
+let reset_mask i =
+  lnot (3 lsl ((i land 7) lsl 1))
+
+(* Initialize the lookup table from a list of segments, assigning
+   a status to every character of each segment. The order of these
+   assignments is relevant: it is possible to assign status [s] to
+   a segment [(c1, c2)] and later assign [s'] to [c] even if [c] is
+   between [c1] and [c2]. *)
+let mk_lookup_table_from_unicode_tables_for status tables =
+  List.iter
+    (List.iter
+       (fun (c1, c2) ->
+          for i = c1 to c2 do
+            table.(i lsr 3) <-
+              (table.(i lsr 3) land (reset_mask i)) lor (mask i status)
+          done))
+    tables
+
+(* Look up into the table and interpret the found pattern. *)
+let lookup x =
+  let v = (table.(x lsr 3) lsr ((x land 7) lsl 1)) land 3 in
+    if      v = 1 then UnicodeLetter
+    else if v = 2 then UnicodeIdentPart
+    else if v = 3 then UnicodeSymbol
+    else raise UnsupportedUtf8
+
+(* [classify_unicode] discriminates between 3 different kinds of
+   symbols based on the standard unicode classification (extracted from
+   Camomile). *)
+let classify_unicode =
+  let single c = [ (c, c) ] in
+    (* General tables. *)
+    mk_lookup_table_from_unicode_tables_for UnicodeSymbol
+      [
+        Unicodetable.sm;           (* Symbol, maths.             *)
+        Unicodetable.sc;           (* Symbol, currency.          *)
+        Unicodetable.so;           (* Symbol, modifier.          *)
+        Unicodetable.pd;           (* Punctation, dash.          *)
+        Unicodetable.pc;           (* Punctation, connector.     *)
+        Unicodetable.pe;           (* Punctation, open.          *)
+        Unicodetable.ps;           (* Punctation, close.         *)
+        Unicodetable.pi;           (* Punctation, initial quote. *)
+        Unicodetable.pf;           (* Punctation, final quote.   *)
+        Unicodetable.po;           (* Punctation, other.         *)
+      ];
+    mk_lookup_table_from_unicode_tables_for UnicodeLetter
+      [
+        Unicodetable.lu;           (* Letter, uppercase.         *)
+        Unicodetable.ll;           (* Letter, lowercase.         *)
+        Unicodetable.lt;           (* Letter, titlecase.         *)
+        Unicodetable.lo;           (* Letter, others.            *)
+      ];
+    mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
+      [
+        Unicodetable.nd;           (* Number, decimal digits.    *)
+        Unicodetable.nl;           (* Number, letter.            *)
+        Unicodetable.no;           (* Number, other.             *)
+      ];
+    (* Exceptions (from a previous version of this function). *)
+    mk_lookup_table_from_unicode_tables_for UnicodeSymbol
+      [
+        single 0x000B2;            (* Squared.                   *)
+        single 0x0002E;            (* Dot.                       *)
+      ];
+    mk_lookup_table_from_unicode_tables_for UnicodeLetter
+      [
+        single 0x005F;             (* Underscore.                *)
+        single 0x00A0;             (* Non breaking space.        *)
+      ];
+    mk_lookup_table_from_unicode_tables_for UnicodeIdentPart
+      [
+        single 0x0027;             (* Special space.             *)
+      ];
+    (* Lookup *)
+    lookup
 
 exception End_of_input
 
 let utf8_of_unicode n =
-  if n < 128 then 
+  if n < 128 then
     String.make 1 (Char.chr n)
   else if n < 2048 then
     let s = String.make 2 (Char.chr (128 + n mod 64)) in
@@ -294,18 +278,18 @@ let utf8_of_unicode n =
     end
   else if n < 65536 then
     let s = String.make 3 (Char.chr (128 + n mod 64)) in
-    begin 
+    begin
       s.[1] <- Char.chr (128 + (n / 64) mod 64);
-      s.[0] <- Char.chr (224 + n / 4096); 
+      s.[0] <- Char.chr (224 + n / 4096);
       s
     end
   else
     let s = String.make 4 (Char.chr (128 + n mod 64)) in
-    begin 
+    begin
       s.[2] <- Char.chr (128 + (n / 64) mod 64);
       s.[1] <- Char.chr (128 + (n / 4096) mod 64);
       s.[0] <- Char.chr (240 + n / 262144);
-      s 
+      s
     end
 
 let next_utf8 s i =
@@ -358,7 +342,7 @@ let check_ident_gen handle s =
 	i := !i + j
       done
     with End_of_input -> ()
-  with 
+  with
   | End_of_input -> error "The empty string is not an identifier."
   | UnsupportedUtf8 -> error (s^": unsupported character in utf8 sequence.")
   | Invalid_argument _ -> error (s^": invalid utf8 sequence.")
@@ -366,127 +350,21 @@ let check_ident_gen handle s =
 let check_ident_soft = check_ident_gen warning
 let check_ident = check_ident_gen error
 
-let lowercase_unicode s unicode =
-    match unicode land 0x1F000 with
-    | 0x0 ->
-    begin match unicode with
-    (* utf-8 Basic Latin underscore *)
-    | x when x = 0x005F -> x
-    (* utf-8 Basic Latin letters *)
-    | x when 0x0041 <= x & x <= 0x005A -> x + 32
-    | x when 0x0061 <= x & x <= 0x007A -> x
-    (* utf-8 Latin-1 non breaking space U00A0 *)
-    | 0x00A0 as x -> x
-    (* utf-8 Latin-1 letters U00C0-00D6 *)
-    | x when 0x00C0 <= x & x <= 0x00D6 -> x + 32
-    (* utf-8 Latin-1 letters U00D8-00F6 *)
-    | x when 0x00D8 <= x & x <= 0x00DE -> x + 32
-    | x when 0x00E0 <= x & x <= 0x00F6 -> x
-    (* utf-8 Latin-1 letters U00F8-00FF *)
-    | x when 0x00F8 <= x & x <= 0x00FF -> x
-    (* utf-8 Latin Extended A U0100-017F and Latin Extended B U0180-U0241 *)
-    | x when 0x0100 <= x & x <= 0x017F ->
-	if x mod 2 = 1 then x else x + 1
-    | x when 0x0180 <= x & x <= 0x0241 ->
-	warning ("Unable to decide which lowercase letter to map to "^s); x
-    (* utf-8 Phonetic letters U0250-02AF *)
-    | x when 0x0250 <= x & x <= 0x02AF -> x
-    (* utf-8 what do to with diacritics U0300-U036F ? *)
-    (* utf-8 Greek letters U0380-03FF *)
-    | x when 0x0380 <= x & x <= 0x0385 -> x
-    | 0x0386 -> 0x03AC
-    | x when 0x0388 <= x & x <= 0x038A -> x + 37
-    | 0x038C -> 0x03CC
-    | x when 0x038E <= x & x <= 0x038F -> x + 63
-    | x when 0x0390 <= x & x <= 0x03AB & x <> 0x03A2 -> x + 32
-    (* utf-8 Greek lowercase letters U03B0-03CE *)	
-    | x when 0x03AC <= x & x <= 0x03CE -> x
-    | x when 0x03CF <= x & x <= 0x03FF ->
-	warning ("Unable to decide which lowercase letter to map to "^s); x
-    (* utf-8 Cyrillic letters U0400-0481 *)
-    | x when 0x0400 <= x & x <= 0x040F -> x + 80
-    | x when 0x0410 <= x & x <= 0x042F -> x + 32
-    | x when 0x0430 <= x & x <= 0x045F -> x 
-    | x when 0x0460 <= x & x <= 0x0481 ->
-	if x mod 2 = 1 then x else x + 1
-    (* utf-8 Cyrillic letters U048A-U4F9 (Warning: 04CF) *)
-    | x when 0x048A <= x & x <= 0x04F9 & x <> 0x04CF -> 
-	if x mod 2 = 1 then x else x + 1
-    (* utf-8 Cyrillic supplement letters U0500-U050F *)
-    | x when 0x0500 <= x & x <= 0x050F ->
-	if x mod 2 = 1 then x else x + 1
-    (* utf-8 Hebrew letters U05D0-05EA *)
-    | x when 0x05D0 <= x & x <= 0x05EA -> x
-    (* utf-8 Arabic letters U0621-064A *)
-    | x when 0x0621 <= x & x <= 0x064A -> x
-    (* utf-8 Arabic supplement letters U0750-076D *)
-    | x when 0x0750 <= x & x <= 0x076D -> x
-    | _ -> raise UnsupportedUtf8
-    end
-    | 0x1000 ->
-    begin match unicode with
-    (* utf-8 Georgian U10A0-10FF (has holes) *)
-    | x when 0x10A0 <= x & x <= 0x10FF -> x
-    (* utf-8 Hangul Jamo U1100-11FF (has holes) *)
-    | x when 0x1100 <= x & x <= 0x11FF -> x
-    (* utf-8 Latin additional letters U1E00-1E9B and U1EA0-1EF9 *)
-    | x when 0x1E00 <= x & x <= 0x1E95 ->
-	if x mod 2 = 1 then x else x + 1
-    | x when 0x1E96 <= x & x <= 0x1E9B -> x
-    | x when 0x1EA0 <= x & x <= 0x1EF9 ->
-	if x mod 2 = 1 then x else x + 1
-    | _ -> raise UnsupportedUtf8
-    end
-    | 0x2000 ->
-    begin match unicode with
-    (* utf-8 general punctuation U2080-2089 *)
-    (* Hyphens *)
-    | x when 0x2010 <= x & x <= 0x2011 -> x
-    (* utf-8 letter-like U2100-214F *)
-    | 0x2102 (* double-struck C *) -> Char.code 'x'
-    | 0x2115 (* double-struck N *) -> Char.code 'n'
-    | 0x2119 (* double-struck P *) -> Char.code 'x'
-    | 0x211A (* double-struck Q *) -> Char.code 'x'
-    | 0x211D (* double-struck R *) -> Char.code 'r'
-    | 0x2124 (* double-struck Z *) -> Char.code 'x'
-    | x when 0x2100 <= x & x <= 0x214F ->
-	warning ("Unable to decide which lowercase letter to map to "^s); x
-    | _ -> raise UnsupportedUtf8
-    end
-    | _ ->
-    begin match unicode with
-    (* utf-8 Hiragana U3040-309F and Katakana U30A0-30FF *)
-    | x when 0x3040 <= x & x <= 0x30FF -> x
-    (* utf-8 Unified CJK Ideographs U4E00-9FA5 *)
-    | x when 0x4E00 <= x & x <= 0x9FA5 -> x
-    (* utf-8 Hangul syllables UAC00-D7AF *)
-    | x when 0xAC00 <= x & x <= 0xD7AF -> x
-    (* utf-8 Gothic U10330-1034A *)
-    | x when 0x10330 <= x & x <= 0x1034A -> x
-    (* utf-8 Math Alphanumeric Symbols U1D400-1D7FF (letters) (has holes) *)
-    | x when 0x1D6A8 <= x & x <= 0x1D7C9 ->
-        let a = (x - 0x1D6A8) mod 58 in
-        if a <= 16 or (18 <= a & a <= 24)
-        then x + 26 (* all but nabla and theta symbol *)
-        else x
-    | x when 0x1D538 <= x & x <= 0x1D56B ->
-        (* Use ordinary lowercase in both small and capital double-struck *)
-        (x - 0x1D538) mod 26 + Char.code 'a'
-    | x when 0x1D468 <= x & x <= 0x1D6A3 -> (* General case *)
-        if (x - 0x1D400 / 26) mod 2 = 0 then x + 26 else x
-    | x when 0x1D400 <= x & x <= 0x1D7CB -> (* fallback *)
-        x
-    (* utf-8 Math Alphanumeric Symbols U1D400-1D7FF (digits) *)
-    | x when 0x1D7CE <= x & x <= 0x1D7FF -> x
-    | _ -> raise UnsupportedUtf8
-    end
+let lowercase_unicode =
+  let tree = Segmenttree.make Unicodetable.to_lower in
+  fun unicode ->
+    try
+      match Segmenttree.lookup unicode tree with
+	| `Abs c -> c
+	| `Delta d -> unicode + d
+    with Not_found -> unicode
 
 let lowercase_first_char_utf8 s =
   assert (s <> "");
   let j, n = next_utf8 s 0 in
-  utf8_of_unicode (lowercase_unicode (String.sub s 0 j) n)
+  utf8_of_unicode (lowercase_unicode n)
 
-(* For extraction, we need to encode unicode character into ascii ones *)
+(** For extraction, we need to encode unicode character into ascii ones *)
 
 let ascii_of_ident s =
   let check_ascii s =
@@ -499,50 +377,60 @@ let ascii_of_ident s =
     begin try while true do
       let j, n = next_utf8 s !i in
       out :=
-       if n >= 128
-       then Printf.sprintf "%s__U%04x_" !out n
-       else Printf.sprintf "%s%c" !out s.[!i];
+	if n >= 128
+	then Printf.sprintf "%s__U%04x_" !out n
+	else Printf.sprintf "%s%c" !out s.[!i];
       i := !i + j
     done with End_of_input -> () end;
     !out
 
 (* Lists *)
 
-let list_intersect l1 l2 = 
+let rec list_compare cmp l1 l2 =
+  match l1,l2 with
+      [], [] -> 0
+    | _::_, [] -> 1
+    | [], _::_ -> -1
+    | x1::l1, x2::l2 ->
+	(match cmp x1 x2 with
+	   | 0 -> list_compare cmp l1 l2
+	   | c -> c)
+
+let list_intersect l1 l2 =
   List.filter (fun x -> List.mem x l2) l1
 
-let list_union l1 l2 = 
+let list_union l1 l2 =
   let rec urec = function
     | [] -> l2
     | a::l -> if List.mem a l2 then urec l else a::urec l
-  in 
+  in
   urec l1
 
-let list_unionq l1 l2 = 
+let list_unionq l1 l2 =
   let rec urec = function
     | [] -> l2
     | a::l -> if List.memq a l2 then urec l else a::urec l
-  in 
+  in
   urec l1
 
 let list_subtract l1 l2 =
   if l2 = [] then l1 else List.filter (fun x -> not (List.mem x l2)) l1
 
-let list_subtractq l1 l2 = 
+let list_subtractq l1 l2 =
   if l2 = [] then l1 else List.filter (fun x -> not (List.memq x l2)) l1
 
-let list_chop n l = 
+let list_chop n l =
   let rec chop_aux acc = function
     | (0, l2) -> (List.rev acc, l2)
     | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
     | (_, []) -> failwith "list_chop"
-  in 
+  in
   chop_aux [] (n,l)
 
-let list_tabulate f len = 
+let list_tabulate f len =
   let rec tabrec n =
     if n = len then [] else (f n)::(tabrec (n+1))
-  in 
+  in
   tabrec 0
 
 let rec list_make n v =
@@ -550,41 +438,41 @@ let rec list_make n v =
   else if n < 0 then invalid_arg "list_make"
   else v::list_make (n-1) v
 
-let list_assign l n e = 
+let list_assign l n e =
   let rec assrec stk = function
     | ((h::t), 0) -> List.rev_append stk (e::t)
     | ((h::t), n) -> assrec (h::stk) (t, n-1)
     | ([], _) -> failwith "list_assign"
-  in 
+  in
   assrec [] (l,n)
 
 let rec list_smartmap f l = match l with
     [] -> l
-  | h::tl -> 
+  | h::tl ->
       let h' = f h and tl' = list_smartmap f tl in
 	if h'==h && tl'==tl then l
 	else h'::tl'
 
 let list_map_left f = (* ensures the order in case of side-effects *)
   let rec map_rec = function
-    | [] -> [] 
+    | [] -> []
     | x::l -> let v = f x in v :: map_rec l
-  in 
+  in
   map_rec
 
-let list_map_i f = 
+let list_map_i f =
   let rec map_i_rec i = function
-    | [] -> [] 
+    | [] -> []
     | x::l -> let v = f i x in v :: map_i_rec (i+1) l
-  in 
+  in
   map_i_rec
 
-let list_map2_i f i l1 l2 =  
+let list_map2_i f i l1 l2 =
   let rec map_i i = function
     | ([], []) -> []
     | ((h1::t1), (h2::t2)) -> let v = f i h1 h2 in v :: map_i (succ i) (t1,t2)
     | (_, _) -> invalid_arg "map2_i"
-  in 
+  in
   map_i i (l1,l2)
 
 let list_map3 f l1 l2 l3 =
@@ -592,7 +480,7 @@ let list_map3 f l1 l2 l3 =
     | ([], [], []) -> []
     | ((h1::t1), (h2::t2), (h3::t3)) -> let v = f h1 h2 h3 in v::map (t1,t2,t3)
     | (_, _, _) -> invalid_arg "map3"
-  in 
+  in
   map (l1,l2,l3)
 
 let list_map4 f l1 l2 l3 l4 =
@@ -600,41 +488,41 @@ let list_map4 f l1 l2 l3 l4 =
     | ([], [], [], []) -> []
     | ((h1::t1), (h2::t2), (h3::t3), (h4::t4)) -> let v = f h1 h2 h3 h4 in v::map (t1,t2,t3,t4)
     | (_, _, _, _) -> invalid_arg "map4"
-  in 
+  in
   map (l1,l2,l3,l4)
 
-let list_index x = 
+let list_index x =
   let rec index_x n = function
     | y::l -> if x = y then n else index_x (succ n) l
     | [] -> raise Not_found
-  in 
+  in
   index_x 1
 
-let list_index0 x l = list_index x l - 1 
+let list_index0 x l = list_index x l - 1
 
-let list_unique_index x = 
+let list_unique_index x =
   let rec index_x n = function
-    | y::l -> 
-	if x = y then 
+    | y::l ->
+	if x = y then
 	  if List.mem x l then raise Not_found
-	  else n 
+	  else n
 	else index_x (succ n) l
-    | [] -> raise Not_found 
+    | [] -> raise Not_found
   in index_x 1
 
 let list_fold_right_i f i l =
   let rec it_list_f i l a = match l with
     | [] -> a
     | b::l -> f (i-1) b (it_list_f (i-1) l a)
-  in 
+  in
   it_list_f (List.length l + i) l
 
-let list_fold_left_i f = 
+let list_fold_left_i f =
   let rec it_list_f i a = function
-    | [] -> a 
+    | [] -> a
     | b::l -> it_list_f (i+1) (f i a b) l
-  in 
-  it_list_f 
+  in
+  it_list_f
 
 let rec list_fold_left3 f accu l1 l2 l3 =
   match (l1, l2, l3) with
@@ -665,16 +553,16 @@ let list_iter3 f l1 l2 l3 =
     | ([], [], []) -> ()
     | ((h1::t1), (h2::t2), (h3::t3)) -> f h1 h2 h3; iter (t1,t2,t3)
     | (_, _, _) -> invalid_arg "map3"
-  in 
+  in
   iter (l1,l2,l3)
 
 let list_iter_i f l = list_fold_left_i (fun i _ x -> f i x) 0 () l
 
-let list_for_all_i p = 
+let list_for_all_i p =
   let rec for_all_p i = function
-    | [] -> true 
+    | [] -> true
     | a::l -> p i a && for_all_p (i+1) l
-  in 
+  in
   for_all_p
 
 let list_except x l = List.filter (fun y -> not (x = y)) l
@@ -698,32 +586,33 @@ let list_eq_set l1 l2 =
   | a::l2 -> aux (list_remove_first a l1) l2 in
   try aux l1 l2 with Not_found -> false
 
-let list_for_all2eq f l1 l2 = try List.for_all2 f l1 l2 with Failure _ -> false
+let list_for_all2eq f l1 l2 =
+  try List.for_all2 f l1 l2 with Invalid_argument _ -> false
 
-let list_map_i f = 
-  let rec map_i_rec i = function
-    | [] -> [] 
-    | x::l -> let v = f i x in v::map_i_rec (i+1) l
-  in 
-  map_i_rec
+let list_filter_i p =
+  let rec filter_i_rec i = function
+    | [] -> []
+    | x::l -> let l' = filter_i_rec (succ i) l in if p i x then x::l' else l'
+  in
+  filter_i_rec 0
 
 let rec list_sep_last = function
   | [] -> failwith "sep_last"
   | hd::[] -> (hd,[])
   | hd::tl -> let (l,tl) = list_sep_last tl in (l,hd::tl)
 
-let list_try_find_i f = 
+let list_try_find_i f =
   let rec try_find_f n = function
     | [] -> failwith "try_find_i"
     | h::t -> try f n h with Failure _ -> try_find_f (n+1) t
-  in 
+  in
   try_find_f
 
-let list_try_find f = 
+let list_try_find f =
   let rec try_find_f = function
     | [] -> failwith "try_find"
     | h::t -> try f h with Failure _ -> try_find_f t
-  in 
+  in
   try_find_f
 
 let list_uniquize l =
@@ -737,12 +626,12 @@ let list_uniquize l =
     | [] -> List.rev acc
   in aux [] l
 
-let rec list_distinct l = 
+let rec list_distinct l =
   let visited = Hashtbl.create 23 in
   let rec loop = function
     | h::t ->
 	if Hashtbl.mem visited h then false
-	else 
+	else
 	  begin
 	    Hashtbl.add visited h h;
 	    loop t
@@ -755,10 +644,10 @@ let rec list_merge_uniq cmp l1 l2 =
   | [], l2 -> l2
   | l1, [] -> l1
   | h1 :: t1, h2 :: t2 ->
-      let c = cmp h1 h2 in 
-      if c = 0 
+      let c = cmp h1 h2 in
+      if c = 0
       then h1 :: list_merge_uniq cmp t1 t2
-      else if c <= 0 
+      else if c <= 0
       then h1 :: list_merge_uniq cmp t1 l2
       else h2 :: list_merge_uniq cmp l1 t2
 
@@ -787,24 +676,29 @@ let list_subset l1 l2 =
   let rec look = function
     | [] -> true
     | x::ll -> try Hashtbl.find t2 x; look ll with Not_found -> false
-  in 
+  in
   look l1
 
-let list_split_at p = 
-  let rec split_at_loop x y = 
-    match y with 
-      | []      -> ([],[])
-      | (a::l)  -> if (p a) then (List.rev x,y) else split_at_loop (a::x) l
-  in 
-  split_at_loop []
-
-let list_split_by p = 
-  let rec split_loop = function
-  | []      -> ([],[])
-  | (a::l)  ->
-      let (l1,l2) = split_loop l in if (p a) then (a::l1,l2) else (l1,a::l2)
-  in 
-  split_loop
+(* [list_split_at i l] splits [l] into two lists [(l1,l2)] such that [l1++l2=l]
+    and [l1] has length [i].
+    It raises [Failure] when [i] is negative or greater than the length of [l]  *)
+let list_split_at index l =
+  let rec aux i acc = function
+      tl when i = index -> (List.rev acc), tl
+    | hd :: tl -> aux (succ i) (hd :: acc) tl
+    | [] -> failwith "list_split_at: Invalid argument"
+  in aux 0 [] l
+
+(* [list_split_when p l] splits [l] into two lists [(l1,a::l2)] such that
+    [l1++(a::l2)=l], [p a=true] and [p b = false] for every element [b] of [l1].
+    If there is no such [a], then it returns [(l,[])] instead *)
+let list_split_when p =
+  let rec split_when_loop x y =
+    match y with
+      | []      -> (List.rev x,[])
+      | (a::l)  -> if (p a) then (List.rev x,y) else split_when_loop (a::x) l
+  in
+  split_when_loop []
 
 let rec list_split3 = function
   | [] -> ([], [], [])
@@ -824,7 +718,7 @@ let list_firstn n l =
     | (0, l) -> List.rev acc
     | (n, (h::t)) -> aux (h::acc) (pred n, t)
     | _ -> failwith "firstn"
-  in 
+  in
   aux [] (n,l)
 
 let rec list_last = function
@@ -839,20 +733,23 @@ let list_lastn n l =
   in
   if len < n then failwith "lastn" else aux len l
 
-let rec list_skipn n l = match n,l with 
-  | 0, _ -> l 
-  | _, [] -> failwith "list_fromn"
+let rec list_skipn n l = match n,l with
+  | 0, _ -> l
+  | _, [] -> failwith "list_skipn"
   | n, _::l -> list_skipn (pred n) l
 
-let rec list_addn n x l = 
+let rec list_skipn_at_least n l =
+  try list_skipn n l with Failure _ -> []
+
+let rec list_addn n x l =
   if n = 0 then l else x :: (list_addn (pred n) x l)
 
-let list_prefix_of prefl l = 
+let list_prefix_of prefl l =
   let rec prefrec = function
     | (h1::t1, h2::t2) -> h1 = h2 && prefrec (t1,t2)
     | ([], _) -> true
     | (_, _) -> false
-  in 
+  in
     prefrec (prefl,l)
 
 let list_drop_prefix p l =
@@ -860,7 +757,7 @@ let list_drop_prefix p l =
   let rec list_drop_prefix_rec = function
     | ([], tl) -> Some tl
     | (_, []) -> None
-    | (h1::tp, h2::tl) -> 
+    | (h1::tp, h2::tl) ->
 	if h1 = h2 then list_drop_prefix_rec (tp,tl) else None
   in
     match list_drop_prefix_rec (p,l) with
@@ -876,7 +773,7 @@ let list_share_tails l1 l2 =
   let rec shr_rev acc = function
     | ((x1::l1), (x2::l2)) when x1 == x2 -> shr_rev (x1::acc) (l1,l2)
     | (l1,l2) -> (List.rev l1, List.rev l2, acc)
-  in 
+  in
   shr_rev [] (List.rev l1, List.rev l2)
 
 let rec list_fold_map f e = function
@@ -887,10 +784,10 @@ let rec list_fold_map f e = function
          e'',h'::t'
 
 (* (* tail-recursive version of the above function *)
-let list_fold_map f e l = 
-  let g (e,b') h = 
+let list_fold_map f e l =
+  let g (e,b') h =
     let (e',h') = f e h in
-      (e',h'::b') 
+      (e',h'::b')
   in
   let (e',lrev) = List.fold_left g (e,[]) l in
     (e',List.rev lrev)
@@ -914,17 +811,17 @@ let list_union_map f l acc =
     acc
     l
 
-(* A generic cartesian product: for any operator (**), 
-   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]], 
+(* A generic cartesian product: for any operator (**),
+   [list_cartesian (**) [x1;x2] [y1;y2] = [x1**y1; x1**y2; x2**y1; x2**y1]],
    and so on if there are more elements in the lists. *)
 
-let rec list_cartesian op l1 l2 = 
+let rec list_cartesian op l1 l2 =
   list_map_append (fun x -> List.map (op x) l2) l1
 
-(* [list_cartesians] is an n-ary cartesian product: it iterates 
+(* [list_cartesians] is an n-ary cartesian product: it iterates
    [list_cartesian] over a list of lists.  *)
 
-let list_cartesians op init ll = 
+let list_cartesians op init ll =
   List.fold_right (list_cartesian op) ll [init]
 
 (* list_combinations [[a;b];[c;d]] gives [[a;c];[a;d];[b;c];[b;d]] *)
@@ -933,12 +830,12 @@ let list_combinations l = list_cartesians (fun x l -> x::l) [] l
 
 (* Keep only those products that do not return None *)
 
-let rec list_cartesian_filter op l1 l2 = 
+let rec list_cartesian_filter op l1 l2 =
   list_map_append (fun x -> list_map_filter (op x) l2) l1
 
 (* Keep only those products that do not return None *)
 
-let rec list_cartesians_filter op init ll = 
+let rec list_cartesians_filter op init ll =
   List.fold_right (list_cartesian_filter op) ll [init]
 
 (* Drop the last element of a list *)
@@ -947,57 +844,76 @@ let rec list_drop_last = function [] -> assert false | hd :: [] -> [] | hd :: tl
 
 (* Arrays *)
 
-let array_exists f v = 
+let array_compare item_cmp v1 v2 =
+  let c = compare (Array.length v1) (Array.length v2) in
+  if c<>0 then c else
+    let rec cmp = function
+	-1 -> 0
+      | i ->
+	  let c' = item_cmp v1.(i) v2.(i) in
+	  if c'<>0 then c'
+	  else cmp (i-1) in
+    cmp (Array.length v1 - 1)
+
+let array_exists f v =
   let rec exrec = function
     | -1 -> false
     | n -> (f v.(n)) || (exrec (n-1))
-  in 
-  exrec ((Array.length v)-1) 
+  in
+  exrec ((Array.length v)-1)
 
-let array_for_all f v = 
+let array_for_all f v =
   let rec allrec = function
     | -1 -> true
     | n -> (f v.(n)) && (allrec (n-1))
-  in 
-  allrec ((Array.length v)-1) 
+  in
+  allrec ((Array.length v)-1)
 
 let array_for_all2 f v1 v2 =
   let rec allrec = function
     | -1 -> true
     | n -> (f v1.(n) v2.(n)) && (allrec (n-1))
-  in 
+  in
   let lv1 = Array.length v1 in
-  lv1 = Array.length v2 && allrec (pred lv1) 
+  lv1 = Array.length v2 && allrec (pred lv1)
 
 let array_for_all3 f v1 v2 v3 =
   let rec allrec = function
     | -1 -> true
     | n -> (f v1.(n) v2.(n) v3.(n)) && (allrec (n-1))
-  in 
+  in
   let lv1 = Array.length v1 in
-  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1) 
+  lv1 = Array.length v2 && lv1 = Array.length v3 && allrec (pred lv1)
 
 let array_for_all4 f v1 v2 v3 v4 =
   let rec allrec = function
     | -1 -> true
     | n -> (f v1.(n) v2.(n) v3.(n) v4.(n)) && (allrec (n-1))
-  in 
+  in
   let lv1 = Array.length v1 in
   lv1 = Array.length v2 &&
   lv1 = Array.length v3 &&
   lv1 = Array.length v4 &&
-    allrec (pred lv1) 
+    allrec (pred lv1)
 
-let array_for_all_i f i v = 
-  let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in 
+let array_for_all_i f i v =
+  let rec allrec i n = n = Array.length v || f i v.(n) && allrec (i+1) (n+1) in
   allrec i 0
 
-let array_hd v = 
+exception Found of int
+
+let array_find_i (pred: int -> 'a -> bool) (arr: 'a array) : int option =
+  try
+    for i=0 to Array.length arr - 1 do if pred i (arr.(i)) then raise (Found i) done;
+    None
+  with Found i -> Some i
+
+let array_hd v =
   match Array.length v with
     | 0 -> failwith "array_hd"
     | _ -> v.(0)
 
-let array_tl v = 
+let array_tl v =
   match Array.length v with
     | 0 -> failwith "array_tl"
     | n -> Array.sub v 1 (pred n)
@@ -1009,12 +925,12 @@ let array_last v =
 
 let array_cons e v = Array.append [|e|] v
 
-let array_rev t = 
+let array_rev t =
   let n=Array.length t in
-    if n <=0 then () 
+    if n <=0 then ()
     else
       let tmp=ref t.(0) in
-      for i=0 to pred (n/2) do 
+      for i=0 to pred (n/2) do
 	tmp:=t.((pred n)-i);
 	t.((pred n)-i)<- t.(i);
 	t.(i)<- !tmp
@@ -1045,7 +961,7 @@ let array_fold_right2 f v1 v2 a =
 
 let array_fold_left2 f a v1 v2 =
   let lv1 = Array.length v1 in
-  let rec fold a n = 
+  let rec fold a n =
     if n >= lv1 then a else fold (f a v1.(n) v2.(n)) (succ n)
   in
   if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
@@ -1053,25 +969,25 @@ let array_fold_left2 f a v1 v2 =
 
 let array_fold_left2_i f a v1 v2 =
   let lv1 = Array.length v1 in
-  let rec fold a n = 
+  let rec fold a n =
     if n >= lv1 then a else fold (f n a v1.(n) v2.(n)) (succ n)
   in
   if Array.length v2 <> lv1 then invalid_arg "array_fold_left2";
   fold a 0
 
-let array_fold_left_from n f a v = 
+let array_fold_left_from n f a v =
   let rec fold a n =
     if n >= Array.length v then a else fold (f a v.(n)) (succ n)
-  in 
+  in
   fold a n
 
-let array_fold_right_from n f v a = 
+let array_fold_right_from n f v a =
   let rec fold n =
     if n >= Array.length v then a else f v.(n) (fold (succ n))
-  in 
+  in
   fold n
 
-let array_app_tl v l = 
+let array_app_tl v l =
   if Array.length v = 0 then invalid_arg "array_app_tl";
   array_fold_right_from 1 (fun e l -> e::l) v l
 
@@ -1091,9 +1007,9 @@ exception Local of int
 
 (* If none of the elements is changed by f we return ar itself.
    The for loop looks for the first such an element.
-   If found it is temporarily stored in a ref and the new array is produced, 
+   If found it is temporarily stored in a ref and the new array is produced,
    but f is not re-applied to elements that are already checked *)
-let array_smartmap f ar = 
+let array_smartmap f ar =
   let ar_size = Array.length ar in
   let aux = ref None in
   try
@@ -1107,10 +1023,10 @@ let array_smartmap f ar =
     done;
     ar
   with
-      Local i -> 
-	let copy j = 
-	  if j<i then ar.(j) 
-	  else if j=i then 
+      Local i ->
+	let copy j =
+	  if j<i then ar.(j)
+	  else if j=i then
 	    match !aux with Some a' -> a' | None -> failwith "Error"
 	  else f (ar.(j))
 	in
@@ -1118,8 +1034,8 @@ let array_smartmap f ar =
 
 let array_map2 f v1 v2 =
   if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
-  if Array.length v1 == 0 then 
-    [| |] 
+  if Array.length v1 == 0 then
+    [| |]
   else begin
     let res = Array.create (Array.length v1) (f v1.(0) v2.(0)) in
     for i = 1 to pred (Array.length v1) do
@@ -1130,8 +1046,8 @@ let array_map2 f v1 v2 =
 
 let array_map2_i f v1 v2 =
   if Array.length v1 <> Array.length v2 then invalid_arg "array_map2";
-  if Array.length v1 == 0 then 
-    [| |] 
+  if Array.length v1 == 0 then
+    [| |]
   else begin
     let res = Array.create (Array.length v1) (f 0 v1.(0) v2.(0)) in
     for i = 1 to pred (Array.length v1) do
@@ -1143,8 +1059,8 @@ let array_map2_i f v1 v2 =
 let array_map3 f v1 v2 v3 =
   if Array.length v1 <> Array.length v2 ||
      Array.length v1 <> Array.length v3 then invalid_arg "array_map3";
-  if Array.length v1 == 0 then 
-    [| |] 
+  if Array.length v1 == 0 then
+    [| |]
   else begin
     let res = Array.create (Array.length v1) (f v1.(0) v2.(0) v3.(0)) in
     for i = 1 to pred (Array.length v1) do
@@ -1185,7 +1101,7 @@ let pure_functional = false
 let array_fold_map' f v e =
 if pure_functional then
   let (l,e) =
-    Array.fold_right 
+    Array.fold_right
       (fun x (l,e) -> let (y,e) = f x e in (y::l,e))
       v ([],e) in
   (Array.of_list l,e)
@@ -1201,8 +1117,8 @@ let array_fold_map f e v =
 
 let array_fold_map2' f v1 v2 e =
   let e' = ref e in
-  let v' = 
-    array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2 
+  let v' =
+    array_map2 (fun x1 x2 -> let (y,e) = f x1 x2 !e' in e' := e; y) v1 v2
   in
   (v',!e')
 
@@ -1223,6 +1139,11 @@ let array_union_map f a acc =
     acc
     a
 
+let array_rev_to_list a =
+  let rec tolist i res =
+    if i >= Array.length a then res else tolist (i+1) (a.(i) :: res) in
+  tolist 0 []
+
 (* Matrices *)
 
 let matrix_transpose mat =
@@ -1235,10 +1156,12 @@ let identity x = x
 
 let compose f g x = f (g x)
 
-let iterate f = 
+let const x _ = x
+
+let iterate f =
   let rec iterate_f n x =
     if n <= 0 then x else iterate_f (pred n) (f x)
-  in 
+  in
   iterate_f
 
 let repeat n f x =
@@ -1247,7 +1170,7 @@ let repeat n f x =
 let iterate_for a b f x =
   let rec iterate i v = if i > b then v else iterate (succ i) (f i v) in
   iterate a x
- 
+
 (* Misc *)
 
 type ('a,'b) union = Inl of 'a | Inr of 'b
@@ -1263,27 +1186,27 @@ let intmap_to_list m = Intmap.fold (fun n v l -> (n,v)::l) m []
 
 let intmap_inv m b = Intmap.fold (fun n v l -> if v = b then n::l else l) m []
 
-let interval n m = 
+let interval n m =
   let rec interval_n (l,m) =
     if n > m then l else interval_n (m::l,pred m)
-  in 
+  in
   interval_n ([],m)
 
 
-let map_succeed f = 
-  let rec map_f = function 
+let map_succeed f =
+  let rec map_f = function
     | [] -> []
     |  h::t -> try (let x = f h in x :: map_f t) with Failure _ -> map_f t
-  in 
-  map_f 
+  in
+  map_f
 
 (* Pretty-printing *)
-  
+
 let pr_spc = spc
 let pr_fnl = fnl
 let pr_int = int
 let pr_str = str
-let pr_coma () = str "," ++ spc ()
+let pr_comma () = str "," ++ spc ()
 let pr_semicolon () = str ";" ++ spc ()
 let pr_bar () = str "|" ++ spc ()
 let pr_arg pr x = spc () ++ pr x
@@ -1294,7 +1217,7 @@ let nth n = str (ordinal n)
 
 (* [prlist pr [a ; ... ; c]] outputs [pr a ++ ... ++ pr c] *)
 
-let rec prlist elem l = match l with 
+let rec prlist elem l = match l with
   | []   -> mt ()
   | h::t -> Stream.lapp (fun () -> elem h) (prlist elem t)
 
@@ -1302,7 +1225,7 @@ let rec prlist elem l = match l with
    if a strict behavior is needed, use [prlist_strict] instead.
    evaluation is done from left to right. *)
 
-let rec prlist_strict elem l = match l with 
+let rec prlist_strict elem l = match l with
   | []   -> mt ()
   | h::t ->
       let e = elem h in let r = prlist_strict elem t in e++r
@@ -1326,22 +1249,22 @@ let rec pr_sequence elem = function
       let e = elem h and r = pr_sequence elem t in
       if e = mt () then r else e ++ spc () ++ r
 
-(* [pr_enum pr [a ; b ; ... ; c]] outputs 
+(* [pr_enum pr [a ; b ; ... ; c]] outputs
    [pr a ++ str "," ++ pr b ++ str "," ++ ... ++ str "and" ++ pr c] *)
 
 let pr_enum pr l =
   let c,l' = list_sep_last l in
-  prlist_with_sep pr_coma pr l' ++
+  prlist_with_sep pr_comma pr l' ++
   (if l'<>[] then str " and" ++ spc () else mt()) ++ pr c
 
 let pr_vertical_list pr = function
   | [] -> str "none" ++ fnl ()
   | l -> fnl () ++ str "  " ++ hov 0 (prlist_with_sep pr_fnl pr l) ++ fnl ()
-      
+
 let prvecti elem v =
   let n = Array.length v in
   let rec pr i =
-    if i = 0 then 
+    if i = 0 then
       elem 0 v.(0)
     else
       let r = pr (i-1) and e = elem i v.(i) in r ++ e
@@ -1353,10 +1276,10 @@ let prvecti elem v =
 
 let prvect_with_sep sep elem v =
   let rec pr n =
-    if n = 0 then 
+    if n = 0 then
       elem v.(0)
-    else 
-      let r = pr (n-1) and s = sep() and e = elem v.(n) in 
+    else
+      let r = pr (n-1) and s = sep() and e = elem v.(n) in
       r ++ s ++ e
       in
   let n = Array.length v in
@@ -1410,64 +1333,62 @@ let memon_eq eq n f =
 (*s Size of ocaml values. *)
 
 module Size = struct
-  
-  open Obj
 
   (*s Pointers already visited are stored in a hash-table, where
       comparisons are done using physical equality. *)
 
   module H = Hashtbl.Make(
-    struct 
-      type t = Obj.t 
-      let equal = (==) 
-      let hash o = Hashtbl.hash (magic o : int)
+    struct
+      type t = Obj.t
+      let equal = (==)
+      let hash o = Hashtbl.hash (Obj.magic o : int)
     end)
-	       
+
   let node_table = (H.create 257 : unit H.t)
-		     
+
   let in_table o = try H.find node_table o; true with Not_found -> false
-      
+
   let add_in_table o = H.add node_table o ()
-			 
+
   let reset_table () = H.clear node_table
-			 
+
   (*s Objects are traversed recursively, as soon as their tags are less than
       [no_scan_tag]. [count] records the numbers of words already visited. *)
 
-  let size_of_double = size (repr 1.0)
-			 
+  let size_of_double = Obj.size (Obj.repr 1.0)
+
   let count = ref 0
-		
+
   let rec traverse t =
     if not (in_table t) then begin
       add_in_table t;
-      if is_block t then begin
-	let n = size t in
-	let tag = tag t in
-	if tag < no_scan_tag then begin
+      if Obj.is_block t then begin
+	let n = Obj.size t in
+	let tag = Obj.tag t in
+	if tag < Obj.no_scan_tag then begin
 	  count := !count + 1 + n;
 	  for i = 0 to n - 1 do
-      	    let f = field t i in 
-	    if is_block f then traverse f
+      	    let f = Obj.field t i in
+	    if Obj.is_block f then traverse f
 	  done
-	end else if tag = string_tag then
-	  count := !count + 1 + n 
-	else if tag = double_tag then
+	end else if tag = Obj.string_tag then
+	  count := !count + 1 + n
+	else if tag = Obj.double_tag then
 	  count := !count + size_of_double
-	else if tag = double_array_tag then
-	  count := !count + 1 + size_of_double * n 
+	else if tag = Obj.double_array_tag then
+	  count := !count + 1 + size_of_double * n
 	else
 	  incr count
       end
     end
-      
+
   (*s Sizes of objects in words and in bytes. The size in bytes is computed
       system-independently according to [Sys.word_size]. *)
 
   let size_w o =
     reset_table ();
     count := 0;
-    traverse (repr o);
+    traverse (Obj.repr o);
     !count
 
   let size_b o = (size_w o) * (Sys.word_size / 8)
@@ -1493,6 +1414,5 @@ let heap_size_kb () = (heap_size () + 1023) / 1024
 (*s interruption *)
 
 let interrupt = ref false
-let check_for_interrupt () = 
+let check_for_interrupt () =
   if !interrupt then begin interrupt := false; raise Sys.Break end
-