eval.ml 15.9 KB
Newer Older
1
2
open Value
open Run_dispatch
3
open Ident
4

5
exception MultipleDeclaration of id
6
7
type env = t Env.t

8
9
let empty = Env.empty

10
11
12
let eval_unary_op = ref (fun _ -> assert false)
let eval_binary_op = ref (fun _ _ -> assert false)

13
14
15
16
17
18
let enter_value = Env.add
let enter_values l env =
  List.fold_left (fun env (x,v) -> Env.add x v env) env l

let find_value = Env.find

19
(* To write tail-recursive map-like iteration *)
20

21
22
let make_accu () = Pair(nil,Absent)
let get_accu a = snd (Obj.magic a)
23
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
24

25
(* Evaluation of expressions *)
26

27
28
let rec eval env e0 = match e0.Typed.exp_descr with
  | Typed.Forget (e,_) -> eval env e
29
  | Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
30
  | Typed.ExtVar _ -> assert false
31
32
33
34
35
36
37
  | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
  | Typed.Abstraction a -> eval_abstraction env a
  | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
  | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
  | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> Xml (eval env e1, eval env e2, eval env e3)
  | Typed.Xml (_,_) -> assert false
  | Typed.Cst c -> const c
38
  | Typed.String (i,j,s,e) -> String_utf8 (i,j,s, eval env e)
39
40
41
42
43
44
45
  | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
  | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
  | Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
  | Typed.Try (arg,brs) -> eval_try env arg brs
  | Typed.Transform (arg,brs) -> eval_transform env brs (eval env arg) 
  | Typed.Dot (e, l) -> eval_dot l (eval env e)
  | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
  | Typed.UnaryOp (op,e) -> !eval_unary_op op (eval env e)
  | Typed.BinaryOp (op,e1,e2) -> !eval_binary_op op (eval env e1) (eval env e2)
  | Typed.Validate (e, schema, name) -> eval_validate env e schema name
  | Typed.Ref (e,t) -> eval_ref env e t


and eval_ref env e t=
  let r = ref (eval env e) in
  let get = 
    Abstraction ([Sequence.nil_type, Types.descr t], fun _ -> !r)
  and set = 
    Abstraction 
      ([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in
  Record (Builtin_defs.mk_ref ~get ~set)

and eval_validate env e schema name = 
  let validator = Typer.get_schema_validator (schema, name) in
  (*
  (* DEBUG *)
    let s = Schema_xml.pxp_stream_of_value (eval env e) in
    Schema_xml.dump_stream s;
  *)
  Schema_validator.validate ~validator
    (Schema_xml.pxp_stream_of_value (eval env e))
70

71
72
73
74
75
76
77
78
79
80
81

and eval_try env arg brs =
  try eval env arg
  with (CDuceExn v) as exn ->
    match eval_branches env brs v with
      | Value.Absent -> raise exn
      | x -> x

and eval_abstraction env a =
  let env = 
    IdSet.fold
82
      (fun accu x -> Env.add x (Env.find x env) accu)
83
      Env.empty a.Typed.fun_fv in
84
85
86
87
88
89
90
91
92
93
94
  match a.Typed.fun_name with
    | None -> 
	Abstraction (a.Typed.fun_iface, eval_branches env a.Typed.fun_body)
    | Some f -> 
	let self = ref Value.Absent in
	let env = Env.add f (Value.Delayed self) env in
	let a = 
	  Abstraction 
	    (a.Typed.fun_iface, eval_branches env a.Typed.fun_body) in
	self := a;
	a
95
96
97

and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
98
  | _ -> assert false
99
100
101
102

and eval_branches env brs arg =
  let (disp, rhs) = Typed.dispatcher brs in
  let (code, bindings) = run_dispatcher disp arg in
103
104
105
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let env = 
106
107
108
	  List.fold_left (
	    fun env (x,i) -> 
	      if (i == -1) then Env.add x arg env 
109
	      else Env.add x bindings.(i) env) env bind in
110
111
	eval env e
    | Patterns.Compile.Fail -> Value.Absent
112
113
114
115
116

and eval_let_decl env l =
  let v = eval env l.Typed.let_body in
  let (disp,bind) = Typed.dispatcher_let_decl l in
  let (_,bindings) = run_dispatcher disp v in
117
118
119
120
121
122
  List.fold_left
    (fun env (x,i) -> 
       let v = if (i == -1) then v else bindings.(i) in
       enter_value x v env
    )
    env
123
    bind
124

125
126
127
128
129
130
131
132
133
134
135
136
137
and eval_rec_funs env l =
  let slots = 
    List.fold_left
      (fun accu -> function  
	 | { Typed.exp_descr=Typed.Abstraction 
			       { Typed.fun_name = Some f } } as e ->
	     (f, e, ref Absent) :: accu
	 | _ -> assert false
      ) [] l in
  let env' = 
    List.fold_left 
      (fun env (f, _ ,s) -> Env.add f (Delayed s) env) 
      env slots in
138
139
  List.iter (fun (_, e, s) -> s := eval env' e) slots;
  env'
140

141
and eval_map env brs v =
142
  map (eval_map_aux env brs) v
143

144
145
146
147
148
149
150
151
and eval_map_aux env brs acc = function
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      let acc' = Pair (x, Absent) in
      set_cdr acc acc';
      eval_map_aux env brs acc' y
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map_aux env brs acc (normalize v)
152
153
154
  | Concat (x,y) ->
      let acc = eval_map_aux env brs acc x in
      eval_map_aux env brs acc y
155
  | _ -> acc
156

157
and eval_transform env brs v =
158
  map (eval_transform_aux env brs) v
159

160
and eval_transform_aux env brs acc = function
161
  | Pair (x,y) -> 
162
163
164
      (match eval_branches env brs x with 
	 | Value.Absent -> eval_transform_aux env brs acc y
	 | x -> eval_transform_aux env brs (append_cdr acc x) y)
165
  | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
166
      (* TODO: raise this test outside the loop *)
167
      if Types.Char.is_empty (brs.Typed.br_accept) 
168
169
      then eval_transform_aux env brs acc q
      else eval_transform_aux env brs acc (normalize v)
170
171
172
  | Concat (x,y) ->
      let acc = eval_transform_aux env brs acc x in
      eval_transform_aux env brs acc y
173
  | _ -> acc
174

175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193

and eval_xtrans env brs v =
  map (eval_xtrans_aux env brs) v

and eval_xtrans_aux env brs acc = function
  | String_utf8 (s,i,j,q) as v ->
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then 
	let acc' = String_utf8 (s,i,j, Absent) in
	set_cdr acc acc';
	eval_xtrans_aux env brs acc' q
      else eval_xtrans_aux env brs acc (normalize v)
  | String_latin1 (s,i,j,q) as v ->
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then 
	let acc' = String_latin1 (s,i,j, Absent) in
	set_cdr acc acc';
	eval_xtrans_aux env brs acc' q
      else eval_xtrans_aux env brs acc (normalize v)
194
195
196
  | Concat (x,y) ->
      let acc = eval_xtrans_aux env brs acc x in
      eval_xtrans_aux env brs acc y
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
  | Pair (x,y) -> 
      let acc = 
	match eval_branches env brs x with
	  | Absent -> 
	      let x = match x with
		| Xml (tag, attr, child) -> 
		    let child = eval_xtrans env brs child in
		    Xml (tag, attr, child)
		| x -> x in
	      let acc' = Pair (x, Absent) in
	      set_cdr acc acc';
	      acc'
	  | x -> append_cdr acc x
      in
      eval_xtrans_aux env brs acc y
  | _ -> acc

214
and eval_dot l = function
215
  | Record r -> LabelMap.assoc l r
216
217
  | _ -> assert false

218
219
220
and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270



(* Non tail-rec version:

and eval_transform env brs = function
  | Pair (x,y) -> 
      (match eval_branches env brs x with 
	 | Value.Absent -> eval_transform env brs y
	 | x -> concat x (eval_transform env brs y))
  | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then eval_transform env brs q
      else eval_transform env brs (normalize v)
  | q -> q

and eval_xtrans env brs = function
  | String_utf8 (s,i,j,q) as v ->
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then String_utf8 (s,i,j, eval_xtrans env brs q)
      else eval_xtrans env brs (normalize v)
  | String_latin1 (s,i,j,q) as v ->
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then String_latin1 (s,i,j, eval_xtrans env brs q)
      else eval_xtrans env brs (normalize v)
  | Pair (x,y) -> 
      (match eval_branches env brs x with
	 | Absent -> 
	     let x = match x with
	       | Xml (tag, attr, child) -> 
		   let child = eval_xtrans env brs child in
		   Xml (tag, attr, child)
	       | x -> x in
	     let y = eval_xtrans env brs y in
	     Pair (x,y)
	 | x ->
	     let y = eval_xtrans env brs y in
	     concat x y)
  | q -> q

and eval_map env brs = function
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map env brs (normalize v)
  | q -> q


*)
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294



(* Evaluator for "compiled" expressions *)


module L = struct

open Lambda

let dispatcher brs =
  match brs.brs_compiled with
    | Some d -> d
    | None ->
	let x = Patterns.Compile.make_branches brs.brs_input brs.brs in
	brs.brs_compiled <- Some x;
	x



let stack = ref (Array.create 1024 Value.Absent)
let frame = ref 0
let sp = ref 0

295
296
297
298
299
let comp_unit () =
  let r = Array.sub !stack 0 !sp in
  sp := 0;
  r

300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
let dump ppf =
  Format.fprintf ppf "sp = %i   frame = %i@." !sp !frame;
  for i = 0 to !sp - 1 do
    if i = !frame then Format.fprintf ppf "FRAME@.";
    Format.fprintf ppf "%a@." Value.print !stack.(i)
  done 

let ensure a i = 
  let n = Array.length !a in 
  if i = n then (
    let b = Array.create (max (n*2) i) Value.Absent in
    Array.blit !a 0 b 0 n;
    a := b
  )

let set a i x =
  ensure a i;
  !a.(i) <- x

let push x =
  set stack !sp x;
  incr sp

let calls = ref 0

325
326
let from_comp_unit = ref (fun cu pos -> assert false)

327
328
329
330
331
332
333
334
let eval_var env = function
  | Env i -> env.(i)
  | Global i -> !stack.(i)
  | Stack i -> !stack.(!frame + i) 
  | Dummy -> Value.Absent

let rec eval env = function
  | Var x -> eval_var env x
335
  | ExtVar (cu,pos) -> !from_comp_unit cu pos
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
  | Apply (false,e1,e2) -> 
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      eval_apply v1 v2
  | Apply (true,e1,e2) -> 
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      eval_apply_tail_rec v1 v2
  | Abstraction (slots,iface,body) -> eval_abstraction env slots iface body
  | Const c -> Value.const c
  | Pair (e1,e2) -> 
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      Value.Pair (v1,v2)
  | Xml (e1,e2,e3) -> 
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      let v3 = eval env e3 in
      Value.Xml (v1,v2,v3)
  | Record r -> Value.Record (LabelMap.map (eval env) r)
  | String (i,j,s,q) -> Value.String_utf8 (i,j,s,eval env q)
  | Match (e,brs) -> eval_branches env brs (eval env e)

  | Map (arg,brs) -> eval_map env brs (eval env arg)
  | Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
  | Try (arg,brs) -> eval_try env arg brs
  | Transform (arg,brs) -> eval_transform env brs (eval env arg) 
  | Dot (e, l) -> eval_dot l (eval env e)
  | RemoveField (e, l) -> eval_remove_field l (eval env e)
  | UnaryOp (op,e) -> !eval_unary_op op (eval env e)
  | BinaryOp (op,e1,e2) ->  
      let v1 = eval env e1 in
      let v2 = eval env e2 in
      !eval_binary_op op v1 v2
  | Validate (e, schema, name) -> eval_validate env e schema name
  | Ref (e,t) -> eval_ref env e t

and eval_abstraction env slots iface body =
  let local_env = Array.map (eval_var env) slots in
  let a = Value.Abstraction2 (local_env,iface,body) in
  local_env.(0) <- a;
  a

and eval_apply f arg =
(*  Format.fprintf Format.std_formatter
    "Apply %i@." !calls;
  incr calls;*)
  match f with
    | Value.Abstraction2 (local_env,_,body) -> 
	let saved_frame = !frame and saved_sp = !sp in 
	frame := !sp;
	let v = eval_branches local_env body arg in
	frame := saved_frame;
	sp := saved_sp;
	v
    | Value.Abstraction (_,f) -> f arg
    | _  -> assert false

and eval_apply_tail_rec f arg =
(*  Format.fprintf Format.std_formatter
    "Apply tail %i@." !calls;
  incr calls;*)
  match f with
    | Value.Abstraction2 (local_env,_,body) -> 
	sp := !frame;
	eval_branches local_env body arg
    | Value.Abstraction (_,f) -> f arg
    | _  -> assert false



and eval_branches env brs arg =
  let (disp, rhs) = dispatcher brs in
  let (code, bindings) = Run_dispatch.run_dispatcher disp arg in
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let saved_sp = !sp in
413
414
	List.iter 
	  (fun (_,i) -> push (if (i == -1) then arg else bindings.(i)))
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
	  bind;
 	if brs.brs_tail 
	then eval env e 
	else
	  let v = eval env e in
	  sp := saved_sp;
	  v
    | Patterns.Compile.Fail -> Value.Absent

and eval_ref env e t=
  let r = ref (eval env e) in
  let get = 
    Value.Abstraction ([Sequence.nil_type, Types.descr t], fun _ -> !r)
  and set = 
    Value.Abstraction 
      ([Types.descr t, Sequence.nil_type], fun x -> r := x; nil) in
  Value.Record (Builtin_defs.mk_ref ~get ~set)

and eval_validate env e schema name = 
  let validator = Typer.get_schema_validator (schema, name) in
  Schema_validator.validate ~validator 
    (Schema_xml.pxp_stream_of_value (eval env e))

and eval_try env arg brs =
  let saved_frame = !frame and saved_sp = !sp in
  try eval env arg
  with (CDuceExn v) as exn ->
    frame := saved_frame;
    sp := saved_sp;
    match eval_branches env brs v with
      | Value.Absent -> raise exn
      | x -> x

and eval_map env brs v =
  map (eval_map_aux env brs) v

and eval_map_aux env brs acc = function
  | Value.Pair (x,y) -> 
      let x = eval_branches env brs x in
      let acc' = Value.Pair (x, Absent) in
      set_cdr acc acc';
      eval_map_aux env brs acc' y
  | Value.String_latin1 (_,_,_,_) | Value.String_utf8 (_,_,_,_) as v -> 
      eval_map_aux env brs acc (normalize v)
459
460
461
  | Value.Concat (x,y) ->
      let acc = eval_map_aux env brs acc x in
      eval_map_aux env brs acc y
462
463
464
465
466
467
468
469
470
471
472
473
474
475
  | _ -> acc

and eval_transform env brs v =
  map (eval_transform_aux env brs) v

and eval_transform_aux env brs acc = function
  | Value.Pair (x,y) -> 
      (match eval_branches env brs x with 
	 | Value.Absent -> eval_transform_aux env brs acc y
	 | x -> eval_transform_aux env brs (append_cdr acc x) y)
  | Value.String_latin1 (_,_,_,q) | Value.String_utf8 (_,_,_,q) as v -> 
      if not brs.brs_accept_chars
      then eval_transform_aux env brs acc v
      else eval_transform_aux env brs acc (normalize v)
476
477
478
  | Value.Concat (x,y) ->
      let acc = eval_transform_aux env brs acc x in
      eval_transform_aux env brs acc y
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
  | _ -> acc


and eval_xtrans env brs v =
  map (eval_xtrans_aux env brs) v

and eval_xtrans_aux env brs acc = function
  | Value.String_utf8 (s,i,j,q) as v ->
      if not brs.brs_accept_chars
      then 
	let acc' = Value.String_utf8 (s,i,j, Absent) in
	set_cdr acc acc';
	eval_xtrans_aux env brs acc' q
      else eval_xtrans_aux env brs acc (normalize v)
  | Value.String_latin1 (s,i,j,q) as v ->
      if not brs.brs_accept_chars
      then 
	let acc' = Value.String_latin1 (s,i,j, Absent) in
	set_cdr acc acc';
	eval_xtrans_aux env brs acc' q
      else eval_xtrans_aux env brs acc (normalize v)
500
501
502
  | Value.Concat (x,y) ->
      let acc = eval_xtrans_aux env brs acc x in
      eval_xtrans_aux env brs acc y
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
  | Value.Pair (x,y) -> 
      let acc = 
	match eval_branches env brs x with
	  | Value.Absent -> 
	      let x = match x with
		| Value.Xml (tag, attr, child) -> 
		    let child = eval_xtrans env brs child in
		    Value.Xml (tag, attr, child)
		| x -> x in
	      let acc' = Value.Pair (x, Absent) in
	      set_cdr acc acc';
	      acc'
	  | x -> append_cdr acc x
      in
      eval_xtrans_aux env brs acc y
  | _ -> acc

and eval_dot l = function
  | Value.Record r -> LabelMap.assoc l r
  | v -> 
      Value.print Format.std_formatter v;
      failwith ("Cannot find field " ^ (Label.to_string (LabelPool.value l)))


and eval_remove_field l = function
  | Value.Record r -> Value.Record (LabelMap.remove l r)
  | _ -> assert false




534
let eval_expr e = 
535
  assert (!frame = 0);
536
  ignore (eval [||] e)
537

538
let var v =
539
540
541
  assert (!frame = 0);
  eval_var [||] v

542
let eval_let_decl p e =
543
  assert (!frame = 0);
544

545
  let comp = Patterns.Compile.make_branches 
546
	       (Types.descr (Patterns.accept p)) [ p, () ] in
547
548
549
550
551
  let (disp, bind) = 
    match comp with
      | (disp, [| Patterns.Compile.Match (l, ()) |]) -> (disp,l)
      | _ -> assert false in
  
552
  let v = eval [||] e in
553
  let (_, bindings) = Run_dispatch.run_dispatcher disp v in
554
  List.iter (fun (_,i) -> push (if (i == -1) then v else bindings.(i))) bind
555
556
  
let eval_rec_funs funs =
557
558
559
560
561
562
563
564
565
566
567
  assert (!frame = 0);
  List.iter (fun e -> push (eval [||] e)) funs

let expr = function
  | Eval e -> eval [||] e
  | _-> assert false

let eval = function
  | Eval e -> eval_expr e
  | Let_decl (p,e) -> eval_let_decl p e
  | Let_funs funs -> eval_rec_funs funs
568
569

end