source: Deliverables/D5.1/cost-plug-in/wrapper/misc.ml @ 1462

Last change on this file since 1462 was 1462, checked in by ayache, 8 years ago

Added D5.1: Frama-C plug-in and Lustre wrapper. D2.2 (8051) has been updated accordingly.

File size: 3.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
119
120
121let fresh_file prefix suffix =
122  let string_of_complement = function
123    | None -> ""
124    | Some i -> string_of_int i in
125  let next_complement = function
126    | None -> Some 0
127    | Some i -> Some (i+1) in
128  let rec aux complement =
129    let filename = prefix ^ (string_of_complement complement) ^ suffix in
130    if not (Sys.file_exists filename) then filename
131    else aux (next_complement complement) in
132  aux None
133
134let exists_exts base exts =
135  let f res ext = res || (Sys.file_exists (base ^ ext)) in
136  List.fold_left f false exts
137
138let fresh_base base exts =
139  let string_of_complement = function
140    | None -> ""
141    | Some i -> string_of_int i in
142  let next_complement = function
143    | None -> Some 0
144    | Some i -> Some (i+1) in
145  let rec aux complement =
146    let new_base = base ^ (string_of_complement complement) in
147    if not (exists_exts new_base exts) then new_base
148    else aux (next_complement complement) in
149  aux None
150
151let rec repeat n f a =
152  if n = 0 then a
153  else repeat (n-1) f (f a)
Note: See TracBrowser for help on using the repository browser.