var.ml 9.67 KB
Newer Older
1
(*-----------------------------------------------------------------------
2
* Copyright (C) - Verimag.
3
** This file may only be copied under the terms of the GNU Library General
4
** Public License
5
6
7
8
9
10
11
12
**-----------------------------------------------------------------------
**
** File: var.mli
** Author: jahier@imag.fr
*)

type name = string
type mode = Input | Output | Local | Pre
13

14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
(*
module NameMap  = struct
  include Map.Make(
	struct
		type t = name
		let compare = compare
	end
	)
end

module Name2Val = struct
	type t = Value.t NameMap.t
	let empty:t = NameMap.empty
	let get (n2v:t) (n:name) = NameMap.find n n2v
	let add (n2v:t) ((n,v):name * Value.t) = NameMap.add n v n2v
	let add_list (n2v:t) (l:(name * Value.t) list) = List.fold_left add n2v l
	let from_list (l:(name * Value.t) list) = List.fold_left add empty l
	let union (x1:t) (x2:t) = NameMap.fold (fun n v x -> add x (n,v)) x1 x2 
	let support (x:t) = NameMap.fold (fun n v acc -> n::acc) x []
	let partition f (x:t) = NameMap.fold
		(fun n v (yes, no) -> if f (n,v) then (add yes (n,v), no) else (yes, add no (n,v))) x (empty,empty)
	let content (x:t) = (
		List.fast_sort (fun (vn1, _) (vn2, _) -> compare vn1 vn2)
			(NameMap.fold (fun n v acc -> (n,v)::acc) x [])
	)
	let to_string (pfx:string) (x:t) = (
		if x = empty then pfx^"empty\n"
		else (
			let nv2s (n,v) = pfx ^ "\t" ^ (Prevar.format n) ^ " = " ^ (Value.to_string v) ^ "\n" in
			let str_l = List.map nv2s (content x) in
			String.concat "" str_l
		)
	)
	let print (x:t) (oc:out_channel) = output_string oc (to_string "" x)
	let mapi = NameMap.mapi
	let iter = NameMap.iter
end
*)
52

53
type vnt = name * Type.t
54
55
56
57
58

type subst = (name * Value.t)
type num_subst = (name * Value.num)


59
60
61
62
63
(* type env_in  = (name, Value.t) Hashtbl.t *)
type env     = Value.OfIdent.t
type env_in  = Value.OfIdent.t
type env_out = Value.OfIdent.t
type env_loc = Value.OfIdent.t
64

65
let (sort_list_string_pair:  (string * 'a) list -> (string * 'a) list) =
66
67
  fun var_list ->
    List.sort (fun (vn1, t1) (vn2, t2) -> compare vn1 vn2) var_list
68
69


70
71
72
73
74
75
76
77
let (subst_list_to_string : string -> subst list -> string) =
  fun prefix sl -> 
    let str_l = List.map
      (fun (vn, e) -> prefix ^ "\t" ^ (Prevar.format vn) ^ " = " ^ (Value.to_string e) ^ "\n")
      (sort_list_string_pair sl)
    in
      String.concat "" str_l

78
let (print_subst_list : subst list -> out_channel -> unit) =
79
  fun sl oc ->
80
    output_string oc (subst_list_to_string "" sl)
81

82

83

84

85
86
87
88
89
90
91
(* let (print_env_out : env_out -> out_channel -> unit) = print_subst_list *)
(* let (print_env_loc : env_loc -> out_channel -> unit) = print_subst_list *)
let (print_env_out : env_out -> out_channel -> unit) = Value.OfIdent.print
let (print_env_loc : env_out -> out_channel -> unit) = Value.OfIdent.print
let (print_env_in : env_in -> out_channel -> unit) = Value.OfIdent.print

(* OBSOLETE 
92
let (print_env_in : env_in -> out_channel -> unit) =
93
94
95
  fun tbl oc ->
    Hashtbl.iter
    (fun vn e ->
96
97
       output_string oc (Prevar.format vn) ;
       output_string oc " = ";
98
       Value.print oc e;
99
       output_string oc "\n\t"
100
    )
101
    tbl
102
*)
103

104
105
let (get_val_env_in : env_in -> name -> Value.t) = 
  fun env n -> 
106
107
    (* try Hashtbl.find env n  *)
    try Value.OfIdent.get env n 
erwan's avatar
erwan committed
108
109
110
111
112
    with Not_found -> (* I should rather raise a specific exception *)
      print_string (
          "Error: a (Lutin program) input is missing: " ^ n  ^ "\n" ^
            "E: Maybe this program is not bootable (able to start without input)\n"^
              "E: and used as an environment of Lurette or rdbg?\n");
113
114
115
      flush stdout;
      exit 2

116

117
(* OBSOLETE ?
118
let (inputs_to_list : env_in -> subst list) =
119
120
  fun inputs ->
    Hashtbl.fold
121
122
123
    (fun name value acc -> (name, value)::acc)
       inputs
       []
124
*)
125

126
127
(* let (get_val_env_out : env_out -> name -> Value.t) = fun l n -> List.assoc n l *)
let (get_val_env_out : env_out -> name -> Value.t) = Value.OfIdent.get
128

129
130
(* let (get_val_env_loc : env_loc -> name -> Value.t) = fun l n -> List.assoc n l *)
let (get_val_env_loc : env_loc -> name -> Value.t) = Value.OfIdent.get
131
132
133



134
135
136
137
138
(* let (init_env_out : unit -> env_out) = fun _  -> [] *)
(* let (init_env_loc : unit -> env_loc) = fun _  -> [] *)
let (init_env_out : unit -> env_out) = fun _  -> Value.OfIdent.empty
let (init_env_loc : unit -> env_loc) = fun _  -> Value.OfIdent.empty
let (init_env_in : unit -> env_in) = fun _  -> Value.OfIdent.empty
139
140

type 'a t = {
141
  index   : int;
142
  n       : name;
143
  t       : Type.t;
144
145
146
147
148
  mode    : mode;
  alias   : 'a option;
  min     : 'a option;
  max     : 'a option;
  default : 'a option;
149
  init    : 'a option
150
151
152
153
154
}

let (name : 'a t -> name) =
  fun var -> var.n

155
let (typ : 'a t -> Type.t) =
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
  fun var -> var.t

let (mode : 'a t -> mode) =
  fun var -> var.mode

let (min : 'a t -> 'a option) =
  fun var -> var.min

let (max : 'a t -> 'a option) =
  fun var -> var.max

let (alias : 'a t -> 'a option) =
  fun var -> var.alias

let (default : 'a t -> 'a option) =
  fun var -> var.default

let (init : 'a t -> 'a option) =
  fun var -> var.init

176
177
178
let (index : 'a t -> int) =
  fun var -> var.index

179

180
181
(* global counter that is incremented each time a variable is created *)
let var_cpt = ref 0
182

183

184
(* exported *)
185
186
let (make : string -> string -> Type.t -> mode -> 'a t) =
  fun lv_pref n t m ->
187
(*     let _ = print_string (n^"\n") ; flush stdout in *)
188
189
190
191
192
193
    let n' =
      if 
	m <> Local 
      then 
	n
      else
194
	(* Rename non-local vars to avoid clashes *)
195
196
197
198
199
200
201
202
	let l  = String.length lv_pref 
	and ln = String.length n 
	in
	  if ln < l || (String.sub n 0 l) <> lv_pref then
	    (lv_pref ^ n)
	  else
	    n
    in
203
204
205
206
207
208
    let idx = !var_cpt in
(*       print_string ("variable " ^ n' ^ "  -> " ^ (string_of_int idx) ^ "\n"); *)
(*       flush stdout; *)
      incr var_cpt;
      {n=n'; t=t; mode=m;alias=None; min=None; max=None; 
       default=None; init=None ; index = idx}
209

210

211
let (change_type : 'a t -> Type.t -> 'a t) =
212
  fun var t ->
213
    {
214
215
      n=var.n;
      t = t;
216
      mode=var.mode;
217
218
219
220
      alias=var.alias;
      min = var.min;
      max=var.max;
      default=var.default;
221
222
      init=var.init;
      index =var.index
223
    }
224
225


226
let (set_min : 'a t -> 'a  -> 'a t) =
227
  fun var min ->
228
229
230
231
232
    {
      n=var.n;
      t=var.t;
      mode=var.mode;
      alias=var.alias;
233
      min = Some min;
234
235
236
237
238
      max=var.max;
      default=var.default;
      init=var.init;
      index =var.index
    }
239

240
let (set_max : 'a t -> 'a -> 'a t) =
241
  fun var max ->
242
243
244
245
246
247
    {
      n=var.n;
      t=var.t;
      mode=var.mode;
      alias=var.alias;
      min=var.min;
248
      max = Some max;
249
250
251
252
      default=var.default;
      init=var.init;
      index =var.index
    }
253

254
let (set_alias : 'a t -> 'a -> 'a t) =
255
256
  fun var alias ->
    {
257
258
      n=var.n;
      t=var.t;
259
      mode=var.mode;
260
      alias = Some alias;
261
262
263
      min=var.min;
      max=var.max;
      default=var.default;
264
265
      init=var.init;
      index =var.index
266
267
    }

268
let (set_default : 'a t -> 'a -> 'a t) =
269
  fun var default ->
270
    {
271
272
      n=var.n;
      t=var.t;
273
      mode=var.mode;
274
275
276
      alias=var.alias;
      min=var.min;
      max=var.max;
277
      default = Some default;
278
279
      init=var.init;
      index =var.index
280
281
    }

282
let (set_init : 'a t -> 'a -> 'a t) =
283
  fun var init ->
284
    {
285
286
      n=var.n;
      t=var.t;
287
      mode=var.mode;
288
289
290
291
      alias=var.alias;
      min=var.min;
      max=var.max;
      default=var.default;
292
      init = Some init;
293
      index =var.index
294
295
296
    }


297
298
299
300
301
302
303
304
let (make_pre : 'a t -> 'a t) =
  fun var -> 
    let pre_str = Prevar.give_pre_var_name var.n in
    let pv = make ""  pre_str var.t Pre in
      match var.init with
           None  -> pv 
        | Some i ->  set_init pv i

305
let (mode_of_string : string -> mode) =
306
  fun str ->
307
308
309
310
311
312
313
    match str with
	"inputs" -> Input
      | "outputs" -> Output
      | "locals" -> Local
      | _ -> assert false

let (mode_to_string : mode -> string) =
314
  fun m ->
315
    match m with
316
317
318
	Input -> "input"
      | Output -> "output"
      | Local -> "local"
319
      | Pre -> "pre"
320

321

322
let (print_format : 'a t -> unit) =
323
  fun var ->
324
325
    Format.print_string (
      var.n ^ ":" ^
326
      (Type.to_string var.t) ^ ":" ^
327
328
      (mode_to_string var.mode) ^ " min=" ^
      (if var.min = None then "None" else "Some ...") ^ " max=" ^
329
      (if var.max = None then  "None" else "Some ...") ^
330
331
332
333
334
(*       " \n\talias=" ^ *)
(*       (if var.alias = None then  "None" else "Some ...") ^ " \n\tdefault=" ^ *)
(*       (if var.default = None then  "None" else "Some ...") ^ " \n\tinit=" ^ *)
(*       (if var.init = None then  "None" else "Some ...")  *)
      "\n")
335

336
let (to_string : 'a t -> string) =
337
  fun var ->
338
    (
339
340
      var.n ^ ":" ^
      (Type.to_string var.t) ^ ":" ^
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
      (mode_to_string var.mode) ^ 
      " min=" ^ (if var.min = None then "None" else "Some ...") ^ 
      " max=" ^ (if var.max = None then  "None" else "Some ...") ^
      " alias=" ^ (if var.alias = None then  "None" else "Some ...") ^
      " default=" ^ (if var.default = None then  "None" else "Some ...") ^
      " init=" ^ (if var.init = None then  "None" else "Some ...") ^
      " index=" ^ (string_of_int var.index) ^
      "\n")

let (to_string_verbose : ('a -> string) -> 'a t -> string) =
  fun convert var ->
    (
      var.n ^ ":" ^
      (Type.to_string var.t) ^ ":" ^
      (mode_to_string var.mode) ^ 
      " min=" ^ (match var.min with None -> "None" |Some x  -> ( convert x)) ^ 
      " max=" ^ (match var.max with None -> "None" |Some x  -> ( convert x)) ^ 
      " alias=" ^ (match var.alias with None -> "None" |Some x  -> ( convert x)) ^ 
      " default=" ^ (match var.default with None -> "None" |Some x  -> ( convert x)) ^ 
      " init=" ^ (match var.init with None -> "None" |Some x  -> ( convert x)) ^ 
361
362
363
      " index=" ^ (string_of_int var.index)
    )
      (* "\n") *)
364

365
366
367
368
369
370
371



let (print : 'a t -> unit) =
  fun var ->
    print_string (to_string var)
    
372
373
374
let (is_newer : 'a t -> 'a t -> int) =
  fun var1 var2 -> 
    var1.index - var2.index