eval.ml 5.65 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
10
11
12
13
14
15
16
let set_cdr x q = Obj.set_field (Obj.repr x) 1 (Obj.repr q)

let seq_accu () = Pair (nil,nil)
let append_accu x y = let acc = Pair (y,nil) in set_cdr x acc; acc
let get_accu = function
  | Pair (x,y) -> y
  | _ -> assert false


17
18
(* Evaluation of expressions *)

19

20
21
let rec eval env e0 = match e0.Typed.exp_descr with
  | Typed.Forget (e,_) -> eval env e
22
  | Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
  | 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)
39
40
41
42
  | Typed.Validate (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))
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
and eval_map env brs = function
113
114
115
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
116
117
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map env brs (normalize v)
118
119
120
  | q -> q
  

121
and eval_transform env brs = function
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
  | 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_transform env brs v =
  let acc = seq_accu () in
  eval_transform_aux env brs acc v;
  get_accu acc
and eval_transform_aux env brs acc = function
137
  | Pair (x,y) -> 
138
139
140
      let x = 
	match eval_branches env brs x with 
	  | Value.Absent -> Value.nil 
141
142
	  | x -> List.fold_left add_accu acc x
x in
143
      concat x (eval_transform env brs y)
144
145
146
147
  | 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)
148
  | q -> q
149
*)
150

151
and eval_xtrans env brs = function
152
153
154
155
156
157
158
159
  | 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)
160
  | Pair (x,y) -> 
161
162
163
      (match eval_branches env brs x with
	 | Absent -> 
	     let x = match x with
164
	       | Xml (tag, attr, child) -> 
165
		   let child = eval_xtrans env brs child in
166
		   Xml (tag, attr, child)
167
168
169
170
171
	       | x -> x in
	     let y = eval_xtrans env brs y in
	     Pair (x,y)
	 | x ->
	     let y = eval_xtrans env brs y in
172
	     concat x y)
173
174
  | q -> q

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

179
180
181
and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false