eval.ml 4.38 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


(* Evaluation of expressions *)

18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
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 with Not_found -> Env.find s !global_env)
  | 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)


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
      (fun accu x -> 
	 try Env.add x (Env.find x env) accu with Not_found -> accu)
      Env.empty a.Typed.fun_fv in
  let env_ref = ref env in
  let 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
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
  match rhs.(code) with 
    | Patterns.Compile.Match (bind,e) ->
	let env = 
75
76
77
78
	  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
79
80
	eval env e
    | Patterns.Compile.Fail -> Value.Absent
81
82
83
84
85

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

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

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

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

136
and eval_dot l = function
137
  | Record r -> LabelMap.assoc l r
138
139
  | _ -> assert false

140
141
142
and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false