source: Deliverables/D2.2/8051/src/utilities/misc.ml @ 486

Last change on this file since 486 was 486, checked in by ayache, 9 years ago

Deliverable D2.2

File size: 2.5 KB
Line 
1module LexingExt = struct
2
3  open Lexing
4
5  let new_line lexbuf = 
6    lexbuf.lex_curr_p <- { 
7      lexbuf.lex_curr_p with 
8        pos_bol  = 0;
9        pos_lnum = lexbuf.lex_curr_p.pos_lnum + 1
10    }
11
12end
13
14module ListExt = struct
15
16  let inv_assoc l = List.map (fun (x, y) -> (y, x)) l
17
18  exception EmptyList
19
20  let last l = try List.hd (List.rev l) with _ -> raise EmptyList
21
22  let cut_last l = 
23    let rec aux l = function
24      | []      -> raise EmptyList
25      | [ x ]   -> (x, List.rev l)
26      | x :: xs -> aux (x :: l) xs
27    in
28    aux [] l
29
30  let multi_set_of_list l = 
31    let h = Hashtbl.create 13 in 
32    let incr_occ x = 
33      let o = try Hashtbl.find h x with Not_found -> 0 in
34      Hashtbl.replace h x (o + 1)
35    in
36    List.iter incr_occ l;
37    Hashtbl.fold (fun k v accu -> (k, v) :: accu) h []
38
39  let hashtbl_of_assoc l = 
40    let h = Hashtbl.create 13 in 
41    List.iter (fun (k, v) -> Hashtbl.add h k v) l;
42    h
43
44  exception Conflict
45  let assoc_union l1 l2 = 
46    let h1 = hashtbl_of_assoc l1 in
47    l1
48    @ List.filter
49      (fun (k, v1) -> 
50        try 
51          let v2 = Hashtbl.find h1 k in
52          if v1 <> v2 then raise Conflict;
53          false
54        with _ -> true) l2
55
56  let assoc_diff l1 l2 = 
57    let h1 = hashtbl_of_assoc l1 in
58    let h2 = hashtbl_of_assoc l2 in
59    let diff h1 h2 f = 
60      Hashtbl.fold
61        (fun k v1 accu -> 
62          let v2 = 
63            try Some (Hashtbl.find h2 k)
64            with Not_found -> None
65          in
66          if Some v1 <> v2 then 
67            if f then 
68              (k, (Some v1, v2)) :: accu
69            else 
70              (k, (v2, Some v1)) :: accu
71          else
72            accu)
73        h1 []
74    in
75    let d1 = diff h1 h2 true in
76    let d2 = diff h2 h1 false in
77    try assoc_union d1 d2
78    with Conflict -> assert false
79
80  let transitive_forall2 p l = 
81    let rec aux = function
82      | []  -> None
83      | [x] -> None
84      | x1 :: ((x2 :: _) as xs) -> 
85        if not (p x1 x2) then Some (x1, x2) else aux xs
86    in
87    aux l
88
89end
90
91module ArgExt = struct
92
93  let extra_doc s = "", Arg.Unit ignore, s
94
95end
96
97module SysExt = struct
98
99  let safe_remove name =
100    try Sys.remove name with Sys_error _ -> ()
101
102  let rec alternative name = 
103    if not (Sys.file_exists name) then
104      name
105    else 
106      let dirname = Filename.dirname name in
107      let filename = Filename.basename name in
108      let r = Str.regexp "\\([0-9]+\\)-\\(.*\\)" in
109      let filename = 
110        if Str.string_match r filename 0 then
111          let i = int_of_string (Str.matched_group 1 filename) in
112          Printf.sprintf "%02d-%s" (i + 1) (Str.matched_group 2 filename)
113        else 
114          "01-" ^ filename
115      in
116      alternative (Filename.concat dirname filename)
117     
118end
Note: See TracBrowser for help on using the repository browser.