eval.ml 4.34 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
open Value
open Run_dispatch

module Env = Map.Make (struct type t = string let compare = compare end)
type env = t Env.t

let global_env = ref Env.empty
let enter_global x v = global_env := Env.add x v !global_env


11
12
13
let exn_int_of = CDuceExn (Pair (
			     Atom (Types.AtomPool.mk "Invalid_argument"),
			     string "int_of"))
14
15
16
17
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
60
61
62




(* 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
	with Not_found -> Env.find s !global_env)
    | Typed.Apply (f,arg) ->  eval_apply (eval env f) (eval env arg)
    | Typed.Abstraction a ->
	let env = 
	  List.fold_left 
	    (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
       - for the recursive case, could cheat bt pathing self afterwards:
                (Obj.magic self).(1) <- ....
*)
    | Typed.RecordLitt r -> Record (List.map (fun (l,e) -> (l, eval env e)) r)
    | Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
    | 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.Op ("raise", [e]) -> raise (CDuceExn (eval env e))
    | Typed.Try (arg,brs) -> 
	(try eval env arg with CDuceExn v -> eval_branches env brs v)
    | Typed.Op ("flatten", [e]) -> eval_flatten (eval env e)
    | Typed.Op ("@", [e1; e2]) -> eval_concat (eval env e1) (eval env e2)
    | Typed.Op ("+", [e1; e2]) -> eval_add (eval env e1) (eval env e2)
    | Typed.Op ("*", [e1; e2]) -> eval_mul (eval env e1) (eval env e2)
    | Typed.Op ("-", [e1; e2]) -> eval_sub (eval env e1) (eval env e2)
    | Typed.Op ("/", [e1; e2]) -> eval_div (eval env e1) (eval env e2)
    | Typed.Op ("load_xml", [e]) -> eval_load_xml (eval env e)
63
    | Typed.Op ("print_xml", [e]) -> eval_print_xml (eval env e)
64
65
66
67
68
69
70
71
    | Typed.Op ("int_of", [e]) -> eval_int_of (eval env e)
    | Typed.Dot (e, l) -> eval_dot l (eval env e)
    | Typed.DebugTyper t -> failwith "Evaluating a ! expression"
    | Typed.Op (o,_) -> failwith ("Unknown operator " ^ o)


and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
72
  | _ -> eval_concat f arg
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134

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
  let (bind, e) = rhs.(code) in
  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 bind in
  eval env e

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

and eval_map env brs = function
  | Pair (x,y) -> Pair (eval_branches env brs x, eval_map env brs y)
  | String (_,_,_,_) as v -> eval_map env brs (normalize v)
  | q -> q
  
and eval_flatten = function
  | Pair (x,y) -> eval_concat x (eval_flatten y)
  | q -> q

and eval_concat l1 l2 = match l1 with
  | Pair (x,y) -> Pair (x, eval_concat y l2)
  | String (s,i,j,q) -> String (s,i,j, eval_concat q l2)
  | q -> l2

and eval_dot l = function
  | Record r -> List.assoc l r
  | _ -> assert false

and eval_add x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.add_big_int x y)
  | _ -> assert false

and eval_mul x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.mult_big_int x y)
  | _ -> assert false

and eval_sub x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.sub_big_int x y)
  | _ -> assert false

and eval_div x y = match (x,y) with
  | (Integer x, Integer y) -> Integer (Big_int.div_big_int x y)
  | _ -> assert false

and eval_load_xml e =
  Load_xml.run (get_string e)

and eval_int_of e =
  let s = get_string e in
  try Integer (Big_int.big_int_of_string s)
  with Failure _ -> raise exn_int_of
  
135
136
137
and eval_print_xml v =
  string (Print_xml.string_of_xml v)