eval.ml 15.7 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
31
32
33
34
35
36
  | 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
37
  | Typed.String (i,j,s,e) -> String_utf8 (i,j,s, eval env e)
38
39
40
41
42
43
44
  | 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)
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
  | 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))
69

70
71
72
73
74
75
76
77
78
79
80

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
81
      (fun accu x -> Env.add x (Env.find x env) accu)
82
      Env.empty a.Typed.fun_fv in
83
84
85
86
87
88
89
90
91
92
93
  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
94
95
96

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

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

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
116
117
118
119
120
121
  List.fold_left
    (fun env (x,i) -> 
       let v = if (i == -1) then v else bindings.(i) in
       enter_value x v env
    )
    env
122
    bind
123

124
125
126
127
128
129
130
131
132
133
134
135
136
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
137
138
  List.iter (fun (_, e, s) -> s := eval env' e) slots;
  env'
139

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

143
144
145
146
147
148
149
150
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)
151
152
153
  | Concat (x,y) ->
      let acc = eval_map_aux env brs acc x in
      eval_map_aux env brs acc y
154
  | _ -> acc
155

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

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

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

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)
193
194
195
  | Concat (x,y) ->
      let acc = eval_xtrans_aux env brs acc x in
      eval_xtrans_aux env brs acc y
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
  | 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

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

217
218
219
and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false
220
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



(* 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


*)
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
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
325
326
327
328
329
330
331
332
333
334
335
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



(* 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

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

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
  | 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
404
405
	List.iter 
	  (fun (_,i) -> push (if (i == -1) then arg else bindings.(i)))
406
407
408
409
410
411
412
413
414
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
	  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)
450
451
452
  | Value.Concat (x,y) ->
      let acc = eval_map_aux env brs acc x in
      eval_map_aux env brs acc y
453
454
455
456
457
458
459
460
461
462
463
464
465
466
  | _ -> 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)
467
468
469
  | Value.Concat (x,y) ->
      let acc = eval_transform_aux env brs acc x in
      eval_transform_aux env brs acc y
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
  | _ -> 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)
491
492
493
  | Value.Concat (x,y) ->
      let acc = eval_xtrans_aux env brs acc x in
      eval_xtrans_aux env brs acc y
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
  | 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




525
let eval_expr e = 
526
  assert (!frame = 0);
527
  ignore (eval [||] e)
528

529
let var v =
530
531
532
  assert (!frame = 0);
  eval_var [||] v

533
let eval_let_decl p e =
534
  assert (!frame = 0);
535

536
  let comp = Patterns.Compile.make_branches 
537
	       (Types.descr (Patterns.accept p)) [ p, () ] in
538
539
540
541
542
  let (disp, bind) = 
    match comp with
      | (disp, [| Patterns.Compile.Match (l, ()) |]) -> (disp,l)
      | _ -> assert false in
  
543
  let v = eval [||] e in
544
  let (_, bindings) = Run_dispatch.run_dispatcher disp v in
545
  List.iter (fun (_,i) -> push (if (i == -1) then v else bindings.(i))) bind
546
547
  
let eval_rec_funs funs =
548
549
550
551
552
553
554
555
556
557
558
  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
559
560

end