eval.ml 16.3 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
29
let from_comp_unit = ref (fun cu i -> assert false)
let eval_apply = ref (fun f x -> assert false)

30
31
let rec eval env e0 = match e0.Typed.exp_descr with
  | Typed.Forget (e,_) -> eval env e
32
  | Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
33
34
  | Typed.ExtVar (cu,i) -> !from_comp_unit cu i
  | Typed.Apply (f,arg) ->  !eval_apply (eval env f) (eval env arg)
35
36
37
38
39
40
  | 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
41
  | Typed.String (i,j,s,e) -> String_utf8 (i,j,s, eval env e)
42
43
44
45
46
47
48
  | 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)
49
50
  | 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)
51
52
  | Typed.Validate (e, kind, schema, name) ->
      eval_validate env e kind schema name
53
54
55
56
57
58
59
60
61
62
63
64
  | 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)

65
66
67
68
69
70
71
72
73
74
75
76
and eval_validate env e kind schema_name name = 
  let schema = Typer.get_schema schema_name in
  let validate =
    match Schema_common.get_component kind name schema with
    | Schema_types.Type x -> Schema_validator.validate_type x
    | Schema_types.Element x -> Schema_validator.validate_element x
    | Schema_types.Attribute x -> Schema_validator.validate_attribute x
    | Schema_types.Attribute_group x ->
        Schema_validator.validate_attribute_group x
    | Schema_types.Model_group x -> Schema_validator.validate_model_group x
  in
  validate (eval env e)
77
78
79
80
81
82
83
84
85
86
87

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
88
      (fun accu x -> Env.add x (Env.find x env) accu)
89
      Env.empty a.Typed.fun_fv in
90
91
92
93
94
95
96
97
98
99
100
  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
101
(*
102
103
and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
104
  | _ -> assert false
105
*)
106
107
108
109

and eval_branches env brs arg =
  let (disp, rhs) = Typed.dispatcher brs in
  let (code, bindings) = run_dispatcher disp arg in
110
111
112
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let env = 
113
114
115
	  List.fold_left (
	    fun env (x,i) -> 
	      if (i == -1) then Env.add x arg env 
116
	      else Env.add x bindings.(i) env) env bind in
117
118
	eval env e
    | Patterns.Compile.Fail -> Value.Absent
119
120
121
122
123

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
124
125
126
127
128
129
  List.fold_left
    (fun env (x,i) -> 
       let v = if (i == -1) then v else bindings.(i) in
       enter_value x v env
    )
    env
130
    bind
131

132
133
134
135
136
137
138
139
140
141
142
143
144
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
145
146
  List.iter (fun (_, e, s) -> s := eval env' e) slots;
  env'
147

148
and eval_map env brs v =
149
  map (eval_map_aux env brs) v
150

151
152
153
154
155
156
157
158
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)
159
160
161
  | Concat (x,y) ->
      let acc = eval_map_aux env brs acc x in
      eval_map_aux env brs acc y
162
  | _ -> acc
163

164
and eval_transform env brs v =
165
  map (eval_transform_aux env brs) v
166

167
and eval_transform_aux env brs acc = function
168
  | Pair (x,y) -> 
169
170
171
      (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)
172
  | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
173
      (* TODO: raise this test outside the loop *)
174
      if Types.Char.is_empty (brs.Typed.br_accept) 
175
176
      then eval_transform_aux env brs acc q
      else eval_transform_aux env brs acc (normalize v)
177
178
179
  | Concat (x,y) ->
      let acc = eval_transform_aux env brs acc x in
      eval_transform_aux env brs acc y
180
  | _ -> acc
181

182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200

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)
201
202
203
  | Concat (x,y) ->
      let acc = eval_xtrans_aux env brs acc x in
      eval_xtrans_aux env brs acc y
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
  | 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

221
and eval_dot l = function
222
  | Record r -> LabelMap.assoc l r
223
224
  | _ -> assert false

225
226
227
and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false
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
271
272
273
274
275
276
277



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


*)
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301



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

302
303
304
305
306
let comp_unit () =
  let r = Array.sub !stack 0 !sp in
  sp := 0;
  r

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

332
333
let from_comp_unit = ref (fun cu pos -> assert false)

334
335
336
337
338
339
340
341
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
342
  | ExtVar (cu,pos) -> !from_comp_unit cu pos
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
  | 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
377
  | Validate (e, kind, schema, name) -> eval_validate env e kind schema name
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
413
414
415
416
417
418
419
  | 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
420
421
	List.iter 
	  (fun (_,i) -> push (if (i == -1) then arg else bindings.(i)))
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
	  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)

440
441
442
and eval_validate env e kind schema_name name = 
  raise (CDuceExn (string_latin1
    "validate: not implemented for compiled expressions"))
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464

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)
465
466
467
  | Value.Concat (x,y) ->
      let acc = eval_map_aux env brs acc x in
      eval_map_aux env brs acc y
468
469
470
471
472
473
474
475
476
477
478
479
480
481
  | _ -> 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)
482
483
484
  | Value.Concat (x,y) ->
      let acc = eval_transform_aux env brs acc x in
      eval_transform_aux env brs acc y
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
  | _ -> 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)
506
507
508
  | Value.Concat (x,y) ->
      let acc = eval_xtrans_aux env brs acc x in
      eval_xtrans_aux env brs acc y
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
534
535
536
537
538
539
  | 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




540
let eval_expr e = 
541
  assert (!frame = 0);
542
  ignore (eval [||] e)
543

544
let var v =
545
546
547
  assert (!frame = 0);
  eval_var [||] v

548
let eval_let_decl p e =
549
  assert (!frame = 0);
550

551
  let comp = Patterns.Compile.make_branches 
552
	       (Types.descr (Patterns.accept p)) [ p, () ] in
553
554
555
556
557
  let (disp, bind) = 
    match comp with
      | (disp, [| Patterns.Compile.Match (l, ()) |]) -> (disp,l)
      | _ -> assert false in
  
558
  let v = eval [||] e in
559
  let (_, bindings) = Run_dispatch.run_dispatcher disp v in
560
  List.iter (fun (_,i) -> push (if (i == -1) then v else bindings.(i))) bind
561
562
  
let eval_rec_funs funs =
563
564
565
566
567
568
569
570
571
572
573
  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
574
575

end
576
577

let () = eval_apply := L.eval_apply