eval.ml 4.43 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
let global_env = State.ref "Eval.global_env" Env.empty
9
10
11

let enter_global x v = 
  if Env.mem x !global_env then
12
    raise (MultipleDeclaration x);
13
  global_env := Env.add x v !global_env
14
15
16
17
18
19
20
21
22


(* Evaluation of expressions *)

let rec eval env e0 = 
  match e0.Typed.exp_descr with
    | Typed.Forget (e,_) -> eval env e
    | Typed.Var s -> 
	(try Env.find s env
23
	 with Not_found -> Env.find s !global_env)
24
25
26
    | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
    | Typed.Abstraction a ->
	let env = 
27
	  IdSet.fold
28
29
30
31
32
33
34
35
36
37
38
39
40
41
	    (fun accu x -> 
	       try Env.add x (Env.find x env) accu
	       with Not_found -> accu (* global *))
	    Env.empty a.Typed.fun_fv in
	let env_ref = ref env in
	let rec self = Abstraction (a.Typed.fun_iface, 
				    eval_branches' env_ref a.Typed.fun_body) in
	(match a.Typed.fun_name with
	  | None -> ()
	  | Some f -> env_ref := Env.add f self env;
	);
	self
(* Optimizations:
       - for the non-recursive case, use eval_branches
42
       - for the recursive case, could cheat by patching self afterwards:
43
44
                (Obj.magic self).(1) <- ....
*)
45
    | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
46
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
47
48
    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
	Xml (eval env e1, eval env e2, eval env e3)
49
    | Typed.Xml (_,_) -> assert false
50
51
    | Typed.Cst c -> const c
    | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
52
    | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
53
    | Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
54
55
    | Typed.Try (arg,brs) -> (try eval env arg with CDuceExn v -> eval_branches env brs v)
    | Typed.Transform (arg,brs) -> eval_transform env brs (eval env arg) 
56
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
57
    | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
58
59
    | Typed.UnaryOp (o,e) -> o.Typed.un_op_eval (eval env e)
    | Typed.BinaryOp (o,e1,e2) -> o.Typed.bin_op_eval (eval env e1) (eval env e2)
60
61
62
63


and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
64
  | _ -> assert false
65
66
67
68
69
70
71

and eval_branches' env_ref brs arg =
  eval_branches !env_ref brs arg

and eval_branches env brs arg =
  let (disp, rhs) = Typed.dispatcher brs in
  let (code, bindings) = run_dispatcher disp arg in
72
73
74
75
76
77
78
79
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let env = 
	  List.fold_left (fun env (x,i) -> 
			    if (i == -1) then Env.add x arg env 
			    else Env.add x bindings.(i) env) env (IdMap.get bind) in
	eval env e
    | Patterns.Compile.Fail -> Value.Absent
80
81
82
83
84

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
85
  List.map (fun (x,i) -> (x, if (i == -1) then v else bindings.(i))) (IdMap.get bind)
86
87

and eval_map env brs = function
88
89
90
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
91
92
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map env brs (normalize v)
93
94
95
  | q -> q
  

96
and eval_transform env brs = function
97
  | Pair (x,y) -> 
98
      let x = match eval_branches env brs x with Value.Absent -> Value.nil | x -> x in
99
      concat x (eval_transform env brs y)
100
101
102
103
  | 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)
104
105
  | q -> q

106
and eval_xtrans env brs = function
107
108
109
110
111
112
113
114
  | 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)
115
  | Pair (x,y) -> 
116
117
118
      (match eval_branches env brs x with
	 | Absent -> 
	     let x = match x with
119
	       | Xml (tag, attr, child) -> 
120
		   let child = eval_xtrans env brs child in
121
		   Xml (tag, attr, child)
122
123
124
125
126
	       | x -> x in
	     let y = eval_xtrans env brs y in
	     Pair (x,y)
	 | x ->
	     let y = eval_xtrans env brs y in
127
	     concat x y)
128
129
  | q -> q

130
and eval_dot l = function
131
  | Record r -> LabelMap.assoc l r
132
133
  | _ -> assert false

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