viewcvs.cgi/runtime/eval.ml

open Value
open Run_dispatch
open Ident

exception MultipleDeclaration of id
type env = t Env.t

(* Evaluation of expressions *)

let make_accu () = Pair(nil,Absent)
let get_accu a = snd (Obj.magic a)

let dummy () = Absent

let rec eval env e0 = match e0.Typed.exp_descr with
  | Typed.Forget (e,_) -> eval env e
  | Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x | x -> x)
  | 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)
  | Typed.Validate (e, schema, name) ->
      let validator = Typer.get_schema_validator (schema, name) in
(*
        (* DEBUG *)
      let s = Schema_xml.pxp_stream_of_value (eval env e) in
      Schema_xml.dump_stream s;
*)
      Schema_validator.validate ~validator
        (Schema_xml.pxp_stream_of_value (eval env e))

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 self = ref Value.Absent in
  let env = 
    IdSet.fold
      (fun accu x -> Env.add x (Env.find x env) accu)
      Env.empty a.Typed.fun_fv in
  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

and eval_apply f arg = match f with
  | Abstraction (_,clos) -> clos arg
  | _ -> assert false

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
  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

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))) 
    (IdMap.get bind)

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

(*
and eval_map env brs = function
  | Pair (x,y) -> 
      let x = eval_branches env brs x in
      Pair (x, eval_map env brs y)
  | String_latin1 (_,_,_,_) | String_utf8 (_,_,_,_) as v -> 
      eval_map env brs (normalize v)
  | q -> q
*)

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
  

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


(*  
and eval_transform env brs = function
  | 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 acc0 = make_accu () in
  let acc = eval_transform_aux env brs acc0 v in
  set_cdr acc nil;
  get_accu acc0

and eval_transform_aux env brs acc = function
  | Pair (x,y) -> 
      let acc = 
        match eval_branches env brs x with 
          | 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
  | String_latin1 (_,_,_,q) | String_utf8 (_,_,_,q) as v -> 
      if Types.Char.is_empty (brs.Typed.br_accept) 
      then eval_transform_aux env brs acc q
      else eval_transform_aux env brs acc (normalize v)
  | q -> acc

and eval_xtrans env brs = function
  | 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)
  | Pair (x,y) -> 
      (match eval_branches env brs x with
         | Absent -> 
             let x = match x with
               | Xml (tag, attr, child) -> 
                   let child = eval_xtrans env brs child in
                   Xml (tag, attr, child)
               | x -> x in
             let y = eval_xtrans env brs y in
             Pair (x,y)
         | x ->
             let y = eval_xtrans env brs y in
             concat x y)
  | q -> q

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

and eval_remove_field l = function
  | Record r -> Record (LabelMap.remove l r)
  | _ -> assert false
1	abate	70	open Value
2			open Run_dispatch
3	abate	225	open Ident
4	abate	70
5	abate	374	exception MultipleDeclaration of id
6	abate	70	type env = t Env.t
7
8	abate	518	(* Evaluation of expressions *)
9	abate	466
10	abate	518	let make_accu () = Pair(nil,Absent)
11			let get_accu a = snd (Obj.magic a)
12	abate	466
13	abate	518	let dummy () = Absent
14	abate	466
15	abate	425	let rec eval env e0 = match e0.Typed.exp_descr with
16			\| Typed.Forget (e,_) -> eval env e
17	abate	431	\| Typed.Var s -> (match Env.find s env with Value.Delayed x -> !x \| x -> x)
18	abate	425	\| Typed.Apply (f,arg) -> eval_apply (eval env f) (eval env arg)
19			\| Typed.Abstraction a -> eval_abstraction env a
20			\| Typed.RecordLitt r -> Record (LabelMap.map (eval env) r)
21			\| Typed.Pair (e1,e2) -> Pair (eval env e1, eval env e2)
22			\| Typed.Xml (e1, { Typed.exp_descr = Typed.Pair (e2,e3) }) -> Xml (eval env e1, eval env e2, eval env e3)
23			\| Typed.Xml (_,_) -> assert false
24			\| Typed.Cst c -> const c
25			\| Typed.Match (arg,brs) -> eval_branches env brs (eval env arg)
26			\| Typed.Map (arg,brs) -> eval_map env brs (eval env arg)
27			\| Typed.Xtrans (arg,brs) -> eval_xtrans env brs (eval env arg)
28			\| Typed.Try (arg,brs) -> eval_try env arg brs
29			\| Typed.Transform (arg,brs) -> eval_transform env brs (eval env arg)
30			\| Typed.Dot (e, l) -> eval_dot l (eval env e)
31			\| Typed.RemoveField (e, l) -> eval_remove_field l (eval env e)
32			\| Typed.UnaryOp (o,e) -> o.Typed.un_op_eval (eval env e)
33			\| Typed.BinaryOp (o,e1,e2) -> o.Typed.bin_op_eval (eval env e1) (eval env e2)
34	abate	501	\| Typed.Validate (e, schema, name) ->
35			let validator = Typer.get_schema_validator (schema, name) in
36	abate	506	(*
37			(* DEBUG *)
38			let s = Schema_xml.pxp_stream_of_value (eval env e) in
39			Schema_xml.dump_stream s;
40			*)
41	abate	501	Schema_validator.validate ~validator
42			(Schema_xml.pxp_stream_of_value (eval env e))
43	abate	70
44	abate	425	and eval_try env arg brs =
45			try eval env arg
46			with (CDuceExn v) as exn ->
47			match eval_branches env brs v with
48			\| Value.Absent -> raise exn
49			\| x -> x
50
51			and eval_abstraction env a =
52	abate	431	let self = ref Value.Absent in
53	abate	425	let env =
54			IdSet.fold
55	abate	431	(fun accu x -> Env.add x (Env.find x env) accu)
56	abate	425	Env.empty a.Typed.fun_fv in
57	abate	431	match a.Typed.fun_name with
58			\| None ->
59			Abstraction (a.Typed.fun_iface, eval_branches env a.Typed.fun_body)
60			\| Some f ->
61			let self = ref Value.Absent in
62			let env = Env.add f (Value.Delayed self) env in
63			let a =
64			Abstraction
65			(a.Typed.fun_iface, eval_branches env a.Typed.fun_body) in
66			self := a;
67			a
68	abate	425
69	abate	70	and eval_apply f arg = match f with
70			\| Abstraction (_,clos) -> clos arg
71	abate	421	\| _ -> assert false
72	abate	70
73			and eval_branches' env_ref brs arg =
74			eval_branches !env_ref brs arg
75
76			and eval_branches env brs arg =
77			let (disp, rhs) = Typed.dispatcher brs in
78			let (code, bindings) = run_dispatcher disp arg in
79	abate	374	match rhs.(code) with
80			\| Patterns.Compile.Match (bind,e) ->
81			let env =
82	abate	425	List.fold_left (
83			fun env (x,i) ->
84			if (i == -1) then Env.add x arg env
85			else Env.add x bindings.(i) env) env (IdMap.get bind) in
86	abate	374	eval env e
87			\| Patterns.Compile.Fail -> Value.Absent
88	abate	70
89			and eval_let_decl env l =
90			let v = eval env l.Typed.let_body in
91			let (disp,bind) = Typed.dispatcher_let_decl l in
92			let (_,bindings) = run_dispatcher disp v in
93	abate	425	List.map
94			(fun (x,i) -> (x, if (i == -1) then v else bindings.(i)))
95			(IdMap.get bind)
96	abate	70
97	abate	431	and eval_rec_funs env l =
98			let slots =
99			List.fold_left
100			(fun accu -> function
101			\| { Typed.exp_descr=Typed.Abstraction
102			{ Typed.fun_name = Some f } } as e ->
103			(f, e, ref Absent) :: accu
104			\| _ -> assert false
105			) [] l in
106			let env' =
107			List.fold_left
108			(fun env (f, _ ,s) -> Env.add f (Delayed s) env)
109			env slots in
110			List.map (fun (f, e, s) -> s := eval env' e; (f, !s)) slots
111
112	abate	518	(*
113	abate	70	and eval_map env brs = function
114	abate	255	\| Pair (x,y) ->
115			let x = eval_branches env brs x in
116			Pair (x, eval_map env brs y)
117	abate	374	\| String_latin1 (_,_,_,_) \| String_utf8 (_,_,_,_) as v ->
118			eval_map env brs (normalize v)
119	abate	70	\| q -> q
120	abate	518	*)
121
122			and eval_map env brs v =
123			let acc0 = make_accu () in
124			let acc = eval_map_aux env brs acc0 v in
125			set_cdr acc nil;
126			get_accu acc0
127	abate	70
128
129	abate	518	and eval_map_aux env brs acc = function
130			\| Pair (x,y) ->
131			let x = eval_branches env brs x in
132			let acc' = Pair (x, Absent) in
133			set_cdr acc acc';
134			eval_map_aux env brs acc' y
135			\| String_latin1 (_,_,_,_) \| String_utf8 (_,_,_,_) as v ->
136			eval_map_aux env brs acc (normalize v)
137			\| q -> acc
138
139
140			(*
141	abate	245	and eval_transform env brs = function
142	abate	255	\| Pair (x,y) ->
143	abate	466	(match eval_branches env brs x with
144			\| Value.Absent -> eval_transform env brs y
145			\| x -> concat x (eval_transform env brs y))
146			\| String_latin1 (_,_,_,q) \| String_utf8 (_,_,_,q) as v ->
147			if Types.Char.is_empty (brs.Typed.br_accept)
148			then eval_transform env brs q
149			else eval_transform env brs (normalize v)
150			\| q -> q
151	abate	518	*)
152
153	abate	466	and eval_transform env brs v =
154	abate	518	let acc0 = make_accu () in
155			let acc = eval_transform_aux env brs acc0 v in
156			set_cdr acc nil;
157			get_accu acc0
158
159	abate	466	and eval_transform_aux env brs acc = function
160			\| Pair (x,y) ->
161	abate	518	let acc =
162	abate	425	match eval_branches env brs x with
163	abate	518	\| Value.Absent -> acc
164			\| x -> append_cdr acc x
165			(* Need to copy in general; optimization: detect fresh
166			constructors ... *)
167			in
168			eval_transform_aux env brs acc y
169	abate	374	\| String_latin1 (_,_,_,q) \| String_utf8 (_,_,_,q) as v ->
170			if Types.Char.is_empty (brs.Typed.br_accept)
171	abate	518	then eval_transform_aux env brs acc q
172			else eval_transform_aux env brs acc (normalize v)
173			\| q -> acc
174	abate	245
175	abate	331	and eval_xtrans env brs = function
176	abate	374	\| String_utf8 (s,i,j,q) as v ->
177			if Types.Char.is_empty (brs.Typed.br_accept)
178			then String_utf8 (s,i,j, eval_xtrans env brs q)
179			else eval_xtrans env brs (normalize v)
180			\| String_latin1 (s,i,j,q) as v ->
181			if Types.Char.is_empty (brs.Typed.br_accept)
182			then String_latin1 (s,i,j, eval_xtrans env brs q)
183			else eval_xtrans env brs (normalize v)
184	abate	263	\| Pair (x,y) ->
185	abate	374	(match eval_branches env brs x with
186			\| Absent ->
187			let x = match x with
188	abate	405	\| Xml (tag, attr, child) ->
189	abate	374	let child = eval_xtrans env brs child in
190	abate	405	Xml (tag, attr, child)
191	abate	374	\| x -> x in
192			let y = eval_xtrans env brs y in
193			Pair (x,y)
194			\| x ->
195			let y = eval_xtrans env brs y in
196	abate	421	concat x y)
197	abate	263	\| q -> q
198
199	abate	70	and eval_dot l = function
200	abate	233	\| Record r -> LabelMap.assoc l r
201	abate	70	\| _ -> assert false
202
203	abate	240	and eval_remove_field l = function
204			\| Record r -> Record (LabelMap.remove l r)
205			\| _ -> assert false