diff options
Diffstat (limited to 'lib/util.ml')
| -rw-r--r-- | lib/util.ml | 804 |
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 - |