viewcvs.cgi/runtime/eval.ml

open Value
open Run_dispatch
open Ident
open Lambda

let ns_table = ref Ns.empty_table

let ops = Hashtbl.create 13
let register_op = Hashtbl.add ops
let eval_op = Hashtbl.find ops

(* To write tail-recursive map-like iteration *)

let make_accu () = Value.Pair(nil,Absent)
let get_accu a = snd (Obj.magic a)
let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0


let rec ensure a i = 
  let n = Array.length !a in 
  if i >= n then (
    let b = Array.create (max (n*2) i) Value.Absent in
    Array.blit !a 0 b 0 n;
    a := b;
    ensure a i
  )

let set a i x =
  ensure a i;
  !a.(i) <- x


(* For the toplevel *)
let globs = ref (Array.create 64 Value.Absent)
let nglobs = ref 0


let get_globals = ref (fun cu -> assert false)
let get_external = ref (fun cu pos -> assert false)
let set_external = ref (fun cu pos -> assert false)
let get_builtin = ref (fun _ -> assert false)
let run_schema_validator = ref (fun _ _ -> assert false)

let eval_var env locals = function
  | Env i -> env.(i)
  | Local slot -> locals.(slot)
  | Dummy -> Value.Absent
  | Global i -> !globs.(i)
  | Ext (cu,pos) as x ->
      if pos < 0 then (Obj.magic cu : Value.t) else
        let v = (!get_globals cu).(pos) in
        let x = Obj.repr x in
        Obj.set_field x 0 (Obj.repr v);
        Obj.set_field x 1 (Obj.repr (-1));
        v
  | External (cu,pos) as x ->
      if pos < 0 then (Obj.magic cu : Value.t) else
        let v = !get_external cu pos in
        let x = Obj.repr x in
        Obj.set_field x 0 (Obj.repr v);
        Obj.set_field x 1 (Obj.repr (-1));
        v
  | Builtin s ->
      !get_builtin s

let tag_op_resolved = Obj.tag (Obj.repr (OpResolved ((fun _ -> assert false), [])))
let tag_const = Obj.tag (Obj.repr (Const (Obj.magic 0)))

let rec eval env locals = function
  | Var ((Global _ | Ext _ | External _ | Builtin _) as x)  as e ->
      let v = eval_var env locals x in
      Obj.set_field (Obj.repr e) 0 (Obj.repr v);
      Obj.set_tag (Obj.repr e) tag_const;
      v
  | Var x -> eval_var env locals x
  | Apply (e1,e2) -> 
      let v1 = eval env locals e1 in
      let v2 = eval env locals e2 in
      eval_apply v1 v2
  | Abstraction (slots,iface,body,lsize) -> 
      eval_abstraction env locals slots iface body lsize
  | Const c -> c
  | Pair (e1,e2) -> 
      let v1 = eval env locals e1 in
      let v2 = eval env locals e2 in
      Value.Pair (v1,v2)
  | Xml (e1,e2,e3) -> 
      let v1 = eval env locals e1 in
      let v2 = eval env locals e2 in
      let v3 = eval env locals e3 in
      Value.Xml (v1,v2,v3)
  | XmlNs (e1,e2,e3,ns) -> 
      let v1 = eval env locals e1 in
      let v2 = eval env locals e2 in
      let v3 = eval env locals e3 in
      Value.XmlNs (v1,v2,v3,ns)
  | Record r -> 
      Value.Record (Imap.map (eval env locals) r)
  | String (i,j,s,q) -> Value.substring_utf8 i j s (eval env locals q)
  | Match (e,brs) -> eval_branches env locals brs (eval env locals e)
  | Map (arg,brs) -> eval_map env locals brs (eval env locals arg)
  | Xtrans (arg,brs) -> eval_xtrans env locals brs (eval env locals arg)
  | Try (arg,brs) -> eval_try env locals arg brs
  | Transform (arg,brs) -> eval_transform env locals brs (eval env locals arg) 
  | Dot (e, l) -> eval_dot l (eval env locals e)
  | RemoveField (e, l) -> eval_remove_field l (eval env locals e)
  | Validate (e, v) -> eval_validate env locals e v
  | Ref (e,t) -> eval_ref env locals e t
  | Op (op,args) as e -> 
      let eval_fun = eval_op op in
      Obj.set_field (Obj.repr e) 0 (Obj.repr eval_fun);
      Obj.set_tag (Obj.repr e) tag_op_resolved;
      eval_fun (List.map (eval env locals) args)
  | OpResolved (f,args) ->
      f (List.map (eval env locals) args)
  | NsTable (ns,e) -> ns_table := ns; eval env locals e
  | Check (e,d) -> eval_check env locals e d

and eval_check env locals e d =
  Explain.do_check d (eval env locals e)

and eval_abstraction env locals slots iface body lsize =
  let local_env = Array.map (eval_var env locals) slots in
  let f arg =
    eval_branches local_env (Array.create lsize Value.Absent) body arg
  in
  let a = Value.Abstraction (Some iface,f)  in
  local_env.(0) <- a;
  a

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

and eval_branches env locals brs arg =
  let (code, bindings) = Run_dispatch.run_dispatcher brs.brs_disp arg in
  match brs.brs_rhs.(code) with 
    | Auto_pat.Match (n,e) ->
        Array.blit bindings 0 locals brs.brs_stack_pos n;
        eval env locals e 
    | Auto_pat.Fail -> Value.Absent

and eval_ref env locals e t =
  Value.mk_ref (Types.descr t) (eval env locals e)

and eval_validate env locals e s = 
  try Schema_validator.run s (eval env locals e)
  with Schema_common.XSI_validation_error msg ->
    failwith' ("Schema validation failure: " ^ msg)

and eval_try env locals arg brs =
  try eval env locals arg
  with (CDuceExn v) as exn ->
    match eval_branches env locals brs v with
      | Value.Absent -> raise exn
      | x -> x

and eval_map env locals brs v =
  map (eval_map_aux env locals brs) v

and eval_map_aux env locals brs acc = function
  | Value.Pair (x,y) -> 
      let x = eval_branches env locals brs x in
      let acc' = Value.Pair (x, Absent) in
      set_cdr acc acc';
      eval_map_aux env locals brs acc' y
  | Value.String_latin1 (_,_,_,_) | Value.String_utf8 (_,_,_,_) as v -> 
      eval_map_aux env locals brs acc (normalize v)
  | Value.Concat (x,y) ->
      let acc = eval_map_aux env locals brs acc x in
      eval_map_aux env locals brs acc y
  | _ -> acc

and eval_transform env locals brs v =
  map (eval_transform_aux env locals brs) v

and eval_transform_aux env locals brs acc = function
  | Value.Pair (x,y) -> 
      (match eval_branches env locals brs x with 
         | Value.Absent -> eval_transform_aux env locals brs acc y
         | x -> eval_transform_aux env locals brs (append_cdr acc x) y)
  | Value.String_latin1 (_,_,_,q) | Value.String_utf8 (_,_,_,q) as v -> 
      if not brs.brs_accept_chars
      then eval_transform_aux env locals brs acc q
      else eval_transform_aux env locals brs acc (normalize v)
  | Value.Concat (x,y) ->
      let acc = eval_transform_aux env locals brs acc x in
      eval_transform_aux env locals brs acc y
  | _ -> acc

and eval_xtrans env locals brs v =
  map (eval_xtrans_aux env locals brs) v

and eval_xtrans_aux env locals brs acc = function
  | Value.String_utf8 (s,i,j,q) as v ->
      if not brs.brs_accept_chars
      then 
        let acc' = Value.String_utf8 (s,i,j, Absent) in
        set_cdr acc acc';
        eval_xtrans_aux env locals brs acc' q
      else eval_xtrans_aux env locals brs acc (normalize v)
  | Value.String_latin1 (s,i,j,q) as v ->
      if not brs.brs_accept_chars
      then 
        let acc' = Value.String_latin1 (s,i,j, Absent) in
        set_cdr acc acc';
        eval_xtrans_aux env locals brs acc' q
      else eval_xtrans_aux env locals brs acc (normalize v)
  | Value.Concat (x,y) ->
      let acc = eval_xtrans_aux env locals brs acc x in
      eval_xtrans_aux env locals brs acc y
  | Value.Pair (x,y) -> 
      let acc = 
        match eval_branches env locals brs x with
          | Value.Absent -> 
              let x = match x with
                | Value.Xml (tag, attr, child) -> 
                    let child = eval_xtrans env locals brs child in
                    Value.Xml (tag, attr, child)
                | Value.XmlNs (tag, attr, child, ns) ->
                    let child = eval_xtrans env locals brs child in
                    Value.XmlNs (tag, attr, child, ns)
                | x -> x in
              let acc' = Value.Pair (x, Absent) in
              set_cdr acc acc';
              acc'
          | x -> append_cdr acc x
      in
      eval_xtrans_aux env locals brs acc y
  | _ -> acc

and eval_dot l = function
  | Value.Record r 
  | Value.Xml (_,Value.Record r,_)
  | Value.XmlNs (_,Value.Record r,_,_) -> Imap.find_lower r (Upool.int l)
  | v -> assert false

and eval_remove_field l = function
  | Value.Record r -> Value.Record (Imap.remove r (Upool.int l))
  | _ -> assert false


let expr e lsize = eval [||] (Array.create lsize Value.Absent) e

(* Evaluation in the toplevel *)

let eval_toplevel = function
  | Eval (e,lsize) -> ignore (expr e lsize)
  | LetDecls (e,lsize,disp,n) ->
      let v = expr e lsize in
      let (_, bindings) = Run_dispatch.run_dispatcher disp v in
      ensure globs (!nglobs + n);
      Array.blit bindings 0 !globs !nglobs n;
      nglobs := !nglobs + n
  | LetDecl (e,lsize) ->
      let v = expr e lsize in
      set globs !nglobs v;
      incr nglobs

let eval_toplevel items = 
  let n = !nglobs in
  try List.iter eval_toplevel items
  with exn -> nglobs := n; raise exn

let eval_var v = 
  eval_var [||] [||] v

(* Evaluation of a compiled unit *)

let eval_unit globs nglobs = function
  | Eval (e,lsize) -> ignore (expr e lsize)
  | LetDecls (e,lsize,disp,n) ->
      let v = expr e lsize in
      let (_, bindings) = Run_dispatch.run_dispatcher disp v in
      Array.blit bindings 0 globs !nglobs n;
      nglobs := !nglobs + n
  | LetDecl (e,lsize) ->
      let v = expr e lsize in
      globs.(!nglobs) <- v;
      incr nglobs

let eval_unit globs items = 
  let nglobs = ref 0 in
  List.iter (eval_unit globs nglobs) items;
  assert (!nglobs = Array.length globs)

1	abate	70	open Value
2			open Run_dispatch
3	abate	225	open Ident
4	abate	924	open Lambda
5	abate	70
6	abate	1239	let ns_table = ref Ns.empty_table
7	abate	691
8	abate	1237	let ops = Hashtbl.create 13
9			let register_op = Hashtbl.add ops
10			let eval_op = Hashtbl.find ops
11
12	abate	520	(* To write tail-recursive map-like iteration *)
13	abate	466
14	abate	924	let make_accu () = Value.Pair(nil,Absent)
15	abate	518	let get_accu a = snd (Obj.magic a)
16	abate	520	let map f v = let acc0 = make_accu () in set_cdr (f acc0 v) nil; get_accu acc0
17	abate	466
18	abate	1726
19	abate	1746	let rec ensure a i =
20	abate	692	let n = Array.length !a in
21	abate	1746	if i >= n then (
22	abate	692	let b = Array.create (max (n*2) i) Value.Absent in
23			Array.blit !a 0 b 0 n;
24	abate	1746	a := b;
25			ensure a i
26	abate	692	)
27
28			let set a i x =
29			ensure a i;
30			!a.(i) <- x
31
32
33	abate	1746	(* For the toplevel *)
34			let globs = ref (Array.create 64 Value.Absent)
35			let nglobs = ref 0
36	abate	713
37	abate	1746
38			let get_globals = ref (fun cu -> assert false)
39	abate	1177	let get_external = ref (fun cu pos -> assert false)
40			let set_external = ref (fun cu pos -> assert false)
41	abate	1497	let get_builtin = ref (fun _ -> assert false)
42	abate	1746	let run_schema_validator = ref (fun _ _ -> assert false)
43	abate	1497
44	abate	1746	let eval_var env locals = function
45	abate	692	\| Env i -> env.(i)
46	abate	1746	\| Local slot -> locals.(slot)
47	abate	692	\| Dummy -> Value.Absent
48	abate	1746	\| Global i -> !globs.(i)
49	abate	1052	\| Ext (cu,pos) as x ->
50			if pos < 0 then (Obj.magic cu : Value.t) else
51	abate	1746	let v = (!get_globals cu).(pos) in
52	abate	1052	let x = Obj.repr x in
53			Obj.set_field x 0 (Obj.repr v);
54			Obj.set_field x 1 (Obj.repr (-1));
55			v
56	abate	1177	\| External (cu,pos) as x ->
57			if pos < 0 then (Obj.magic cu : Value.t) else
58			let v = !get_external cu pos in
59			let x = Obj.repr x in
60			Obj.set_field x 0 (Obj.repr v);
61			Obj.set_field x 1 (Obj.repr (-1));
62			v
63	abate	1497	\| Builtin s ->
64			!get_builtin s
65	abate	692
66	abate	1746	let tag_op_resolved = Obj.tag (Obj.repr (OpResolved ((fun _ -> assert false), [])))
67			let tag_const = Obj.tag (Obj.repr (Const (Obj.magic 0)))
68	abate	1240
69	abate	1746	let rec eval env locals = function
70			\| Var ((Global _ \| Ext _ \| External _ \| Builtin _) as x) as e ->
71			let v = eval_var env locals x in
72			Obj.set_field (Obj.repr e) 0 (Obj.repr v);
73			Obj.set_tag (Obj.repr e) tag_const;
74			v
75			\| Var x -> eval_var env locals x
76			\| Apply (e1,e2) ->
77			let v1 = eval env locals e1 in
78			let v2 = eval env locals e2 in
79	abate	692	eval_apply v1 v2
80	abate	1746	\| Abstraction (slots,iface,body,lsize) ->
81			eval_abstraction env locals slots iface body lsize
82			\| Const c -> c
83	abate	692	\| Pair (e1,e2) ->
84	abate	1746	let v1 = eval env locals e1 in
85			let v2 = eval env locals e2 in
86	abate	692	Value.Pair (v1,v2)
87			\| Xml (e1,e2,e3) ->
88	abate	1746	let v1 = eval env locals e1 in
89			let v2 = eval env locals e2 in
90			let v3 = eval env locals e3 in
91	abate	692	Value.Xml (v1,v2,v3)
92	abate	1560	\| XmlNs (e1,e2,e3,ns) ->
93	abate	1746	let v1 = eval env locals e1 in
94			let v2 = eval env locals e2 in
95			let v3 = eval env locals e3 in
96	abate	1560	Value.XmlNs (v1,v2,v3,ns)
97	abate	1727	\| Record r ->
98	abate	1746	Value.Record (Imap.map (eval env locals) r)
99			\| String (i,j,s,q) -> Value.substring_utf8 i j s (eval env locals q)
100			\| Match (e,brs) -> eval_branches env locals brs (eval env locals e)
101			\| Map (arg,brs) -> eval_map env locals brs (eval env locals arg)
102			\| Xtrans (arg,brs) -> eval_xtrans env locals brs (eval env locals arg)
103			\| Try (arg,brs) -> eval_try env locals arg brs
104			\| Transform (arg,brs) -> eval_transform env locals brs (eval env locals arg)
105			\| Dot (e, l) -> eval_dot l (eval env locals e)
106			\| RemoveField (e, l) -> eval_remove_field l (eval env locals e)
107			\| Validate (e, v) -> eval_validate env locals e v
108			\| Ref (e,t) -> eval_ref env locals e t
109	abate	1239	\| Op (op,args) as e ->
110	abate	1240	let eval_fun = eval_op op in
111			Obj.set_field (Obj.repr e) 0 (Obj.repr eval_fun);
112			Obj.set_tag (Obj.repr e) tag_op_resolved;
113	abate	1746	eval_fun (List.map (eval env locals) args)
114	abate	1240	\| OpResolved (f,args) ->
115	abate	1746	f (List.map (eval env locals) args)
116			\| NsTable (ns,e) -> ns_table := ns; eval env locals e
117			\| Check (e,d) -> eval_check env locals e d
118	abate	692
119	abate	1746	and eval_check env locals e d =
120			Explain.do_check d (eval env locals e)
121	abate	1398
122	abate	1746	and eval_abstraction env locals slots iface body lsize =
123			let local_env = Array.map (eval_var env locals) slots in
124			let f arg =
125			eval_branches local_env (Array.create lsize Value.Absent) body arg
126			in
127			let a = Value.Abstraction (Some iface,f) in
128	abate	692	local_env.(0) <- a;
129			a
130
131	abate	1746	and eval_apply f arg = match f with
132			\| Value.Abstraction (_,f) -> f arg
133			\| _ -> assert false
134	abate	692
135	abate	1746	and eval_branches env locals brs arg =
136			let (code, bindings) = Run_dispatch.run_dispatcher brs.brs_disp arg in
137			match brs.brs_rhs.(code) with
138			\| Auto_pat.Match (n,e) ->
139			Array.blit bindings 0 locals brs.brs_stack_pos n;
140			eval env locals e
141			\| Auto_pat.Fail -> Value.Absent
142	abate	692
143	abate	1746	and eval_ref env locals e t =
144			Value.mk_ref (Types.descr t) (eval env locals e)
145	abate	692
146	abate	1746	and eval_validate env locals e s =
147			try Schema_validator.run s (eval env locals e)
148	abate	863	with Schema_common.XSI_validation_error msg ->
149			failwith' ("Schema validation failure: " ^ msg)
150	abate	692
151	abate	1746	and eval_try env locals arg brs =
152			try eval env locals arg
153	abate	692	with (CDuceExn v) as exn ->
154	abate	1746	match eval_branches env locals brs v with
155	abate	692	\| Value.Absent -> raise exn
156			\| x -> x
157
158	abate	1746	and eval_map env locals brs v =
159			map (eval_map_aux env locals brs) v
160	abate	692
161	abate	1746	and eval_map_aux env locals brs acc = function
162	abate	692	\| Value.Pair (x,y) ->
163	abate	1746	let x = eval_branches env locals brs x in
164	abate	692	let acc' = Value.Pair (x, Absent) in
165			set_cdr acc acc';
166	abate	1746	eval_map_aux env locals brs acc' y
167	abate	692	\| Value.String_latin1 (_,_,_,_) \| Value.String_utf8 (_,_,_,_) as v ->
168	abate	1746	eval_map_aux env locals brs acc (normalize v)
169	abate	695	\| Value.Concat (x,y) ->
170	abate	1746	let acc = eval_map_aux env locals brs acc x in
171			eval_map_aux env locals brs acc y
172	abate	692	\| _ -> acc
173
174	abate	1746	and eval_transform env locals brs v =
175			map (eval_transform_aux env locals brs) v
176	abate	692
177	abate	1746	and eval_transform_aux env locals brs acc = function
178	abate	692	\| Value.Pair (x,y) ->
179	abate	1746	(match eval_branches env locals brs x with
180			\| Value.Absent -> eval_transform_aux env locals brs acc y
181			\| x -> eval_transform_aux env locals brs (append_cdr acc x) y)
182	abate	692	\| Value.String_latin1 (_,_,_,q) \| Value.String_utf8 (_,_,_,q) as v ->
183			if not brs.brs_accept_chars
184	abate	1746	then eval_transform_aux env locals brs acc q
185			else eval_transform_aux env locals brs acc (normalize v)
186	abate	695	\| Value.Concat (x,y) ->
187	abate	1746	let acc = eval_transform_aux env locals brs acc x in
188			eval_transform_aux env locals brs acc y
189	abate	692	\| _ -> acc
190
191	abate	1746	and eval_xtrans env locals brs v =
192			map (eval_xtrans_aux env locals brs) v
193	abate	692
194	abate	1746	and eval_xtrans_aux env locals brs acc = function
195	abate	692	\| Value.String_utf8 (s,i,j,q) as v ->
196			if not brs.brs_accept_chars
197			then
198			let acc' = Value.String_utf8 (s,i,j, Absent) in
199			set_cdr acc acc';
200	abate	1746	eval_xtrans_aux env locals brs acc' q
201			else eval_xtrans_aux env locals brs acc (normalize v)
202	abate	692	\| Value.String_latin1 (s,i,j,q) as v ->
203			if not brs.brs_accept_chars
204			then
205			let acc' = Value.String_latin1 (s,i,j, Absent) in
206			set_cdr acc acc';
207	abate	1746	eval_xtrans_aux env locals brs acc' q
208			else eval_xtrans_aux env locals brs acc (normalize v)
209	abate	695	\| Value.Concat (x,y) ->
210	abate	1746	let acc = eval_xtrans_aux env locals brs acc x in
211			eval_xtrans_aux env locals brs acc y
212	abate	692	\| Value.Pair (x,y) ->
213			let acc =
214	abate	1746	match eval_branches env locals brs x with
215	abate	692	\| Value.Absent ->
216			let x = match x with
217			\| Value.Xml (tag, attr, child) ->
218	abate	1746	let child = eval_xtrans env locals brs child in
219	abate	692	Value.Xml (tag, attr, child)
220	abate	1560	\| Value.XmlNs (tag, attr, child, ns) ->
221	abate	1746	let child = eval_xtrans env locals brs child in
222	abate	1560	Value.XmlNs (tag, attr, child, ns)
223	abate	692	\| x -> x in
224			let acc' = Value.Pair (x, Absent) in
225			set_cdr acc acc';
226			acc'
227			\| x -> append_cdr acc x
228			in
229	abate	1746	eval_xtrans_aux env locals brs acc y
230	abate	692	\| _ -> acc
231
232			and eval_dot l = function
233	abate	1698	\| Value.Record r
234			\| Value.Xml (_,Value.Record r,_)
235	abate	1746	\| Value.XmlNs (_,Value.Record r,_,_) -> Imap.find_lower r (Upool.int l)
236			\| v -> assert false
237	abate	692
238			and eval_remove_field l = function
239	abate	1746	\| Value.Record r -> Value.Record (Imap.remove r (Upool.int l))
240	abate	692	\| _ -> assert false
241
242
243	abate	1746	let expr e lsize = eval [\|\|] (Array.create lsize Value.Absent) e
244	abate	692
245	abate	1746	(* Evaluation in the toplevel *)
246	abate	692
247	abate	1746	let eval_toplevel = function
248			\| Eval (e,lsize) -> ignore (expr e lsize)
249			\| LetDecls (e,lsize,disp,n) ->
250			let v = expr e lsize in
251			let (_, bindings) = Run_dispatch.run_dispatcher disp v in
252			ensure globs (!nglobs + n);
253			Array.blit bindings 0 !globs !nglobs n;
254			nglobs := !nglobs + n
255			\| LetDecl (e,lsize) ->
256			let v = expr e lsize in
257			set globs !nglobs v;
258			incr nglobs
259	abate	692
260	abate	1746	let eval_toplevel items =
261			let n = !nglobs in
262			try List.iter eval_toplevel items
263			with exn -> nglobs := n; raise exn
264	abate	692
265	abate	1746	let eval_var v =
266			eval_var [\|\|] [\|\|] v
267	abate	698
268	abate	1746	(* Evaluation of a compiled unit *)
269	abate	698
270	abate	1746	let eval_unit globs nglobs = function
271			\| Eval (e,lsize) -> ignore (expr e lsize)
272			\| LetDecls (e,lsize,disp,n) ->
273			let v = expr e lsize in
274			let (_, bindings) = Run_dispatch.run_dispatcher disp v in
275			Array.blit bindings 0 globs !nglobs n;
276			nglobs := !nglobs + n
277			\| LetDecl (e,lsize) ->
278			let v = expr e lsize in
279			globs.(!nglobs) <- v;
280			incr nglobs
281	abate	698
282	abate	1746	let eval_unit globs items =
283			let nglobs = ref 0 in
284			List.iter (eval_unit globs nglobs) items;
285			assert (!nglobs = Array.length globs)
286	abate	714