eval.ml 7.04 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
(* To write tail-recursive map-like iteration *)
9

10
11
let make_accu () = Pair(nil,Absent)
let get_accu a = snd (Obj.magic a)
12
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
13

14
(* Evaluation of expressions *)
15

16
17
let rec eval env e0 = match e0.Typed.exp_descr with
  | Typed.Forget (e,_) -> eval env e
18
  | Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
  | 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
  | 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)
  | 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)
35
36
  | Typed.Validate (e, schema, name) ->
      let validator = Typer.get_schema_validator (schema, name) in
37
38
39
40
41
(*
        (* DEBUG *)
      let s = Schema_xml.pxp_stream_of_value (eval env e) in
      Schema_xml.dump_stream s;
*)
42
43
      Schema_validator.validate ~validator
        (Schema_xml.pxp_stream_of_value (eval env e))
44
45
46
47
48
49
50
51
52

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 =
53
  let self = ref Value.Absent in
54
55
  let env = 
    IdSet.fold
56
      (fun accu x -> Env.add x (Env.find x env) accu)
57
      Env.empty a.Typed.fun_fv in
58
59
60
61
62
63
64
65
66
67
68
  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
69
70
71

and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
72
  | _ -> assert false
73
74
75
76

and eval_branches env brs arg =
  let (disp, rhs) = Typed.dispatcher brs in
  let (code, bindings) = run_dispatcher disp arg in
77
78
79
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let env = 
80
81
82
83
	  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
84
85
	eval env e
    | Patterns.Compile.Fail -> Value.Absent
86
87
88
89
90

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
91
92
93
  List.map 
    (fun (x,i) -> (x, if (i == -1) then v else bindings.(i))) 
    (IdMap.get bind)
94

95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
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
  List.map (fun (f, e, s) -> s := eval env' e; (f, !s)) slots

110
and eval_map env brs v =
111
  map (eval_map_aux env brs) v
112

113
114
115
116
117
118
119
120
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)
121
  | _ -> acc
122

123
and eval_transform env brs v =
124
  map (eval_transform_aux env brs) v
125

126
and eval_transform_aux env brs acc = function
127
  | Pair (x,y) -> 
128
129
130
      (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)
131
  | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
132
      (* TODO: raise this test outside the loop *)
133
      if Types.Char.is_empty (brs.Typed.br_accept) 
134
135
      then eval_transform_aux env brs acc q
      else eval_transform_aux env brs acc (normalize v)
136
  | _ -> acc
137

138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173

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

174
and eval_dot l = function
175
  | Record r -> LabelMap.assoc l r
176
177
  | _ -> assert false

178
179
180
and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230



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


*)