eval.ml 4.58 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
let exn_load_file_utf8 = CDuceExn (Pair (
			     Atom (Atoms.mk_ascii "load_file_utf8"),
			     string_latin1 "File is not a valid UTF-8 stream"))
21
22
23
24
25
26
27
28
29


(* 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
30
	 with Not_found -> Env.find s !global_env)
31
32
33
    | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
    | Typed.Abstraction a ->
	let env = 
34
	  IdSet.fold
35
36
37
38
39
40
41
42
43
44
45
46
47
48
	    (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
49
       - for the recursive case, could cheat by patching self afterwards:
50
51
                (Obj.magic self).(1) <- ....
*)
52
    | Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
53
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
54
55
    | Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> 
	Xml (eval env e1, eval env e2, eval env e3)
56
    | Typed.Xml (_,_) -> assert false
57
58
    | Typed.Cst c -> const c
    | Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
59
    | Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
60
    | Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
61
62
    | 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) 
63
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
64
    | Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
65
66
    | 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)
67
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
82
83
84
85
86
  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
87
88
89
90
91

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

and eval_map env brs = function
95
96
97
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
98
99
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map env brs (normalize v)
100
101
102
  | q -> q
  

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

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

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

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