~ubuntu-branches/ubuntu/vivid/menhir/vivid

« back to all changes in this revision

Viewing changes to misc.ml

  • Committer: Bazaar Package Importer
  • Author(s): Samuel Mimram
  • Date: 2006-07-11 12:26:18 UTC
  • Revision ID: james.westby@ubuntu.com-20060711122618-dea56bmjs3qlmsd8
Tags: upstream-20060615.dfsg
Import upstream version 20060615.dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
1
(**************************************************************************)
 
2
(*                                                                        *)
 
3
(*  Menhir                                                                *)
 
4
(*                                                                        *)
 
5
(*  Fran�ois Pottier and Yann R�gis-Gianas, INRIA Rocquencourt            *)
 
6
(*                                                                        *)
 
7
(*  Copyright 2005 Institut National de Recherche en Informatique et      *)
 
8
(*  en Automatique. All rights reserved. This file is distributed         *)
 
9
(*  under the terms of the Q Public License version 1.0, with the         *)
 
10
(*  change described in file LICENSE.                                     *)
 
11
(*                                                                        *)
 
12
(**************************************************************************)
 
13
 
 
14
let ( $$ ) x f = f x
 
15
 
 
16
let unSome = function
 
17
   None -> assert false
 
18
  | Some x -> x
 
19
 
 
20
let o2s o f =
 
21
  match o with
 
22
  | None ->
 
23
      ""
 
24
  | Some x ->
 
25
      f x
 
26
 
 
27
let single = function
 
28
  | [ x ] ->
 
29
      x
 
30
  | _ ->
 
31
      assert false
 
32
 
 
33
let rec mapd f = function
 
34
  | [] ->
 
35
      []
 
36
  | x :: xs ->
 
37
      let y1, y2 = f x in
 
38
      y1 :: y2 :: mapd f xs
 
39
 
 
40
let tabulateb n f =
 
41
  let a = Array.init n f in
 
42
  Array.get a,
 
43
  Array.fold_left (fun count element ->
 
44
    if element then count + 1 else count
 
45
  ) 0 a
 
46
 
 
47
let tabulateo number fold n f =
 
48
  let a = Array.create n None in
 
49
  let c = ref 0 in
 
50
  let () = fold (fun () element ->
 
51
    let image = f element in
 
52
    a.(number element) <- image;
 
53
    match image with
 
54
    | Some _ ->
 
55
        incr c
 
56
    | None ->
 
57
        ()
 
58
  ) () in
 
59
  let get element =
 
60
    a.(number element)
 
61
  in
 
62
  get, !c
 
63
 
 
64
let rec truncate k xs =
 
65
  match k, xs with
 
66
  | 0, _ ->
 
67
      []
 
68
  | _, [] ->
 
69
      assert false
 
70
  | _, x :: xs ->
 
71
      x :: truncate (k-1) xs
 
72
 
 
73
let truncate k xs =
 
74
  if List.length xs <= k then xs else truncate k xs
 
75
 
 
76
module IntSet = Set.Make (struct 
 
77
                            type t = int
 
78
                            let compare = ( - )
 
79
                          end)
 
80
 
 
81
let separated_list_to_string printer separator list = 
 
82
 
 
83
  let rec loop x = function
 
84
    | [] ->
 
85
        printer x
 
86
    | y :: xs ->
 
87
        printer x 
 
88
        ^ separator 
 
89
        ^ loop y xs
 
90
  in
 
91
 
 
92
  match list with
 
93
  | [] ->
 
94
      ""
 
95
  | x :: xs ->
 
96
      loop x xs
 
97
 
 
98
 
 
99
let index_map string_map = 
 
100
  let n = StringMap.cardinal string_map in
 
101
  let a = Array.create n None in
 
102
  let conv, _ = StringMap.fold 
 
103
    (fun k v (conv, idx) ->
 
104
       a.(idx) <- Some (k, v);
 
105
       StringMap.add k idx conv, idx + 1)
 
106
    string_map (StringMap.empty, 0) 
 
107
  in
 
108
    ((fun n -> snd (unSome a.(n))),
 
109
     (fun k -> StringMap.find k conv),
 
110
     (fun n -> fst (unSome a.(n))))
 
111
  
 
112
let support_assoc l x =
 
113
  try
 
114
    List.assoc x l
 
115
  with Not_found -> x
 
116
 
 
117
let index (strings : string list) : int * string array * int StringMap.t =
 
118
  let name = Array.of_list strings
 
119
  and n, map = List.fold_left (fun (n, map) s ->
 
120
    n+1, StringMap.add s n map
 
121
  ) (0, StringMap.empty) strings in
 
122
  n, name, map
 
123
 
 
124
(* Turning an implicit list, stored using pointers through a hash
 
125
   table, into an explicit list. The head of the implicit list is
 
126
   not included in the explicit list. *)
 
127
 
 
128
let materialize (table : ('a, 'a option) Hashtbl.t) (x : 'a) : 'a list =
 
129
  let rec loop x =
 
130
    match Hashtbl.find table x with
 
131
    | None ->
 
132
        []
 
133
    | Some x ->
 
134
        x :: loop x
 
135
  in
 
136
  loop x
 
137
 
 
138
(* [iteri] implements a [for] loop over integers, from 0 to
 
139
   [n-1]. *)
 
140
 
 
141
let iteri n f =
 
142
  for i = 0 to n - 1 do
 
143
    f i
 
144
  done
 
145
 
 
146
(* [foldi] implements a [for] loop over integers, from 0 to [n-1],
 
147
   with an accumulator. [foldij] implements a [for] loop over
 
148
   integers, from [start] to [n-1], with an accumulator. *)
 
149
 
 
150
let foldij start n f accu =
 
151
  let rec loop i accu =
 
152
    if i = n then
 
153
      accu
 
154
    else
 
155
      loop (i+1) (f i accu)
 
156
  in
 
157
  loop start accu
 
158
 
 
159
let foldi n f accu =
 
160
  foldij 0 n f accu
 
161
 
 
162
(* [qfold f accu q] repeatedly takes an element [x] off the queue [q]
 
163
   and applies [f] to the accumulator and to [x], until [q] becomes
 
164
   empty. Of course, [f] can add elements to [q] as a side-effect.
 
165
 
 
166
   We allocate an option to ensure that [qfold] is tail-recursive. *)
 
167
 
 
168
let rec qfold f accu q =
 
169
  match
 
170
    try
 
171
      Some (Queue.take q)
 
172
    with Queue.Empty ->
 
173
      None
 
174
  with
 
175
  | Some x ->
 
176
      qfold f (f accu x) q
 
177
  | None ->
 
178
      accu
 
179
 
 
180
(* [qiter f q] repeatedly takes an element [x] off the queue [q] and
 
181
   applies [f] to [x], until [q] becomes empty. Of course, [f] can add
 
182
   elements to [q] as a side-effect. *)
 
183
 
 
184
let qiter f q =
 
185
  try
 
186
    while true do
 
187
      f (Queue.take q)
 
188
    done
 
189
  with Queue.Empty ->
 
190
    ()
 
191
 
 
192
let rec smap f = function
 
193
  | [] ->
 
194
      []
 
195
  | (x :: xs) as l ->
 
196
      let x' = f x
 
197
      and xs' = smap f xs in
 
198
      if x == x' && xs == xs' then
 
199
        l
 
200
      else
 
201
        x' :: xs'
 
202
 
 
203
let normalize s =
 
204
  let s = String.copy s in
 
205
  let n = String.length s in
 
206
  for i = 0 to n - 1 do
 
207
    match s.[i] with
 
208
    | '('
 
209
    | ')'
 
210
    | ',' ->
 
211
        s.[i] <- '_'
 
212
    | _ ->
 
213
        ()
 
214
  done;
 
215
  s