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

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

(* Evaluation of expressions *)

10
11
12
13
let make_accu () = Pair(nil,Absent)
let get_accu a = snd (Obj.magic a)

let dummy () = Absent
14

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

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

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

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
79
80
81
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let env = 
82
83
84
85
	  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
86
87
	eval env e
    | Patterns.Compile.Fail -> Value.Absent
88
89
90
91
92

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

97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
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

112
(*
113
and eval_map env brs = function
114
115
116
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
117
118
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map env brs (normalize v)
119
  | q -> q
120
121
122
123
124
125
126
*)

and eval_map env brs v =
  let acc0 = make_accu () in
  let acc = eval_map_aux env brs acc0 v in
  set_cdr acc nil;
  get_accu acc0
127
128
  

129
130
131
132
133
134
135
136
137
138
139
140
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)
  | q -> acc


(*  
141
and eval_transform env brs = function
142
143
144
145
146
147
148
149
150
  | 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
151
152
*)

153
and eval_transform env brs v =
154
155
156
157
158
  let acc0 = make_accu () in
  let acc = eval_transform_aux env brs acc0 v in
  set_cdr acc nil;
  get_accu acc0

159
and eval_transform_aux env brs acc = function
160
  | Pair (x,y) -> 
161
      let acc = 
162
	match eval_branches env brs x with 
163
164
165
166
167
168
	  | Value.Absent -> acc
	  | x -> append_cdr acc x
	      (* Need to copy in general; optimization: detect fresh
		constructors ... *)
      in
      eval_transform_aux env brs acc y
169
170
  | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
      if Types.Char.is_empty (brs.Typed.br_accept) 
171
172
173
      then eval_transform_aux env brs acc q
      else eval_transform_aux env brs acc (normalize v)
  | q -> acc
174

175
and eval_xtrans env brs = function
176
177
178
179
180
181
182
183
  | 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)
184
  | Pair (x,y) -> 
185
186
187
      (match eval_branches env brs x with
	 | Absent -> 
	     let x = match x with
188
	       | Xml (tag, attr, child) -> 
189
		   let child = eval_xtrans env brs child in
190
		   Xml (tag, attr, child)
191
192
193
194
195
	       | x -> x in
	     let y = eval_xtrans env brs y in
	     Pair (x,y)
	 | x ->
	     let y = eval_xtrans env brs y in
196
	     concat x y)
197
198
  | q -> q

199
and eval_dot l = function
200
  | Record r -> LabelMap.assoc l r
201
202
  | _ -> assert false

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