eval.ml 11 KB
Newer Older
1 2
open Value
open Run_dispatch
3
open Ident
4
open Lambda
5

6
let ns_table = ref Ns.empty_table
7

8 9 10 11
let ops = Hashtbl.create 13
let register_op = Hashtbl.add ops
let eval_op = Hashtbl.find ops

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

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

18 19
let rec ensure a i =
  let n = Array.length !a in
20
  if i >= n then (
21 22
    let b = Array.create (max (n*2) i) Value.Absent in
    Array.blit !a 0 b 0 n;
23 24
    a := b;
    ensure a i
25 26 27 28 29 30
  )

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

31 32 33 34 35
(* For the toplevel *)
let globs = ref (Array.create 64 Value.Absent)
let nglobs = ref 0

let get_globals = ref (fun cu -> assert false)
36 37
let get_external = ref (fun cu pos -> assert false)
let set_external = ref (fun cu pos -> assert false)
38
let get_builtin = ref (fun _ -> assert false)
39
let run_schema_validator = ref (fun _ _ -> assert false)
40

41
let eval_var env locals = function
42
  | Env i -> env.(i)
43
  | Local slot -> locals.(slot)
44
  | Dummy -> Value.Absent
45
  | Global i -> !globs.(i)
46 47
  | Ext (cu,pos) as x ->
      if pos < 0 then (Obj.magic cu : Value.t) else
48
	let v = (!get_globals cu).(pos) in
49 50 51 52
	let x = Obj.repr x in
	Obj.set_field x 0 (Obj.repr v);
	Obj.set_field x 1 (Obj.repr (-1));
	v
53 54 55 56 57 58 59
  | 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
60 61
  | Builtin s ->
      !get_builtin s
62

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

66
let pp_lambda_env ppf (env,locals) =
Pietro Abate's avatar
WIP  
Pietro Abate committed
67 68 69
  let aux a =
    let l = Array.to_list a in
    let sl = List.mapi (fun i v ->
70
      Format.fprintf Format.str_formatter "%d : %a" i Value.Print.pp v;
Pietro Abate's avatar
WIP  
Pietro Abate committed
71
      Format.flush_str_formatter ()
72
      ) l
Pietro Abate's avatar
WIP  
Pietro Abate committed
73 74 75
    in
    String.concat "," sl
  in
76
  Format.fprintf ppf "{env = {%s}; locals = {%s}}" (aux env) (aux locals)
Pietro Abate's avatar
WIP  
Pietro Abate committed
77

78
let apply_sigma sigma = function
79
  |Value.Pair(v1,v2,sigma') -> Value.Pair(v1,v2,Value.comp sigma sigma')
Pietro Abate's avatar
Pietro Abate committed
80
  |Value.Abstraction(Some iface,f,sigma') -> Value.Abstraction(Some iface,f,Value.comp sigma sigma')
81 82 83
  |Value.Xml(v1,v2,v3,sigma') -> Value.Xml(v1,v2,v3,Value.comp sigma sigma')
  |Value.XmlNs(v1,v2,v3,ns,sigma') -> Value.XmlNs(v1,v2,v3,ns,Value.comp sigma sigma')
  |Value.Record(m,sigma') -> Value.Record(m,Value.comp sigma sigma')
84 85 86
  |v -> v
;;

87 88
let rec eval_sigma env locals = function
  |Lambda.Comp(s1,s2) -> Value.Comp(eval_sigma env locals s1,eval_sigma env locals s2)
89
  |Lambda.Identity -> Value.Identity
90 91
  |Lambda.List [] -> Value.Mono
  (* |Lambda.List i when i = Types.Tallying.CS.sat -> Value.Identity *)
92
  |Lambda.List l -> Value.List l
Pietro Abate's avatar
Pietro Abate committed
93
  |Lambda.Sel(x,iface,sigma) -> Value.Sel(1,iface,eval_sigma env locals sigma)
94

95
(* env is an array implementing de bruines indexes *)
Pietro Abate's avatar
Pietro Abate committed
96
(* Evaluation rules : Lambda -> Value *)
97 98 99 100 101 102 103
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
104
  | TVar (x,sigma) -> (* delayed sigma application *)
105 106
      let sigma' = eval_sigma env locals sigma in
      apply_sigma sigma' (eval_var env locals x)
107
  | Apply (e1,e2) ->
108 109
      let v1 = eval env locals e1 in
      let v2 = eval env locals e2 in
110
      eval_apply v1 v2
111
  | PolyAbstraction (slots,iface,body,lsize,sigma) ->
112 113
      let sigma' = eval_sigma env locals sigma in
      eval_abstraction env locals slots iface body lsize sigma'
Pietro Abate's avatar
WIP  
Pietro Abate committed
114
  | Abstraction (slots,iface,body,lsize) ->
115
      eval_abstraction env locals slots iface body lsize Value.Mono
116
  | Const c -> c
117
  | Pair (e1,e2) ->
118 119
      let v1 = eval env locals e1 in
      let v2 = eval env locals e2 in
120 121
      (* This is the empty substitution. sigma is associated to a pair only
       * when is from a variable x_sigma *)
122
      Value.Pair (v1,v2,Value.Mono)
123
  | Xml (e1,e2,e3) ->
124 125 126
      let v1 = eval env locals e1 in
      let v2 = eval env locals e2 in
      let v3 = eval env locals e3 in
127
      Value.Xml (v1,v2,v3,Value.Mono)
128
  | XmlNs (e1,e2,e3,ns) ->
129 130 131
      let v1 = eval env locals e1 in
      let v2 = eval env locals e2 in
      let v3 = eval env locals e3 in
132
      Value.XmlNs (v1,v2,v3,ns,Value.Mono)
133
  | Record r ->
134
      Value.Record (Imap.map (eval env locals) r, Value.Mono)
135
  | String (i,j,s,q) -> Value.substring_utf8 i j s (eval env locals q)
136
  (* let is encoded as a match *)
137 138 139 140
  | 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
141
  | Transform (arg,brs) -> eval_transform env locals brs (eval env locals arg)
142 143 144 145
  | 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
146
  | Op (op,args) as e ->
147 148 149
      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;
150
      eval_fun (List.map (eval env locals) args)
151
  | OpResolved (f,args) ->
152 153 154 155 156
      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 =
Pietro Abate's avatar
Pietro Abate committed
157
  Explain.do_check env d (eval env locals e)
158

Pietro Abate's avatar
WIP  
Pietro Abate committed
159 160 161 162
and eval_apply f arg = match f with
  | Value.Abstraction (_,f,_) -> f arg
  | _  -> assert false

163
and eval_abstraction env locals slots iface body lsize sigma =
Pietro Abate's avatar
Pietro Abate committed
164
  let env = Array.map (eval_var env locals) slots in
165
  let f arg =
Pietro Abate's avatar
WIP  
Pietro Abate committed
166
    let v = eval_branches env (Array.create lsize Value.Absent) body arg in
167
    if sigma <> Value.Mono then env.(1) <- arg;
168
    (* pp_lambda_env Format.std_formatter env locals; *)
Pietro Abate's avatar
WIP  
Pietro Abate committed
169 170
    v
  in
171
  let a = Value.Abstraction (Some iface,f,sigma) in
Pietro Abate's avatar
Pietro Abate committed
172
  env.(0) <- a;
173 174
  a

175
and eval_branches env locals brs arg =
Pietro Abate's avatar
Pietro Abate committed
176
  let (code, bindings) = Run_dispatch.run_dispatcher env brs.brs_disp arg in
Pietro Abate's avatar
WIP  
Pietro Abate committed
177 178 179 180 181
  match brs.brs_rhs.(code) with
  | Auto_pat.Match (n,e) ->
      (* copy n elements from bindings into locals starting
       * from position brs.brs_stack_pos *)
      Array.blit bindings 0 locals brs.brs_stack_pos n;
182
      eval env locals e
Pietro Abate's avatar
WIP  
Pietro Abate committed
183
  | Auto_pat.Fail -> Value.Absent
184 185 186 187

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

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

193 194
and eval_try env locals arg brs =
  try eval env locals arg
195
  with (CDuceExn v) as exn ->
196
    match eval_branches env locals brs v with
197 198 199
      | Value.Absent -> raise exn
      | x -> x

200 201
and eval_map env locals brs v =
  map (eval_map_aux env locals brs) v
202

203
and eval_map_aux env locals brs acc = function
204
  | Value.Pair (x,y,sigma) ->
205
      let x = eval_branches env locals brs x in
206
      let acc' = Value.Pair (x, Absent,sigma) in
207
      set_cdr acc acc';
208
      eval_map_aux env locals brs acc' y
209
  | Value.String_latin1 (_,_,_,_) | Value.String_utf8 (_,_,_,_) as v ->
210
      eval_map_aux env locals brs acc (normalize v)
211
  | Value.Concat (x,y, _) ->
212 213
      let acc = eval_map_aux env locals brs acc x in
      eval_map_aux env locals brs acc y
214 215
  | _ -> acc

216 217
and eval_transform env locals brs v =
  map (eval_transform_aux env locals brs) v
218

219
and eval_transform_aux env locals brs acc = function
220 221
  | Value.Pair (x,y,sigma) ->
      (match eval_branches env locals brs x with
222 223
	 | Value.Absent -> eval_transform_aux env locals brs acc y
	 | x -> eval_transform_aux env locals brs (append_cdr acc x) y)
224
  | Value.String_latin1 (_,_,_,q) | Value.String_utf8 (_,_,_,q) as v ->
225
      if not brs.brs_accept_chars
226 227
      then eval_transform_aux env locals brs acc q
      else eval_transform_aux env locals brs acc (normalize v)
228
  | Value.Concat (x,y, _) ->
229 230
      let acc = eval_transform_aux env locals brs acc x in
      eval_transform_aux env locals brs acc y
231 232
  | _ -> acc

233 234
and eval_xtrans env locals brs v =
  map (eval_xtrans_aux env locals brs) v
235

236
and eval_xtrans_aux env locals brs acc = function
237 238
  | Value.String_utf8 (s,i,j,q) as v ->
      if not brs.brs_accept_chars
239
      then
240 241
	let acc' = Value.String_utf8 (s,i,j, Absent) in
	set_cdr acc acc';
242 243
	eval_xtrans_aux env locals brs acc' q
      else eval_xtrans_aux env locals brs acc (normalize v)
244 245
  | Value.String_latin1 (s,i,j,q) as v ->
      if not brs.brs_accept_chars
246
      then
247 248
	let acc' = Value.String_latin1 (s,i,j, Absent) in
	set_cdr acc acc';
249 250
	eval_xtrans_aux env locals brs acc' q
      else eval_xtrans_aux env locals brs acc (normalize v)
251
  | Value.Concat (x,y, _) ->
252 253
      let acc = eval_xtrans_aux env locals brs acc x in
      eval_xtrans_aux env locals brs acc y
254 255
  | Value.Pair (x,y,sigma) ->
      let acc =
256
	match eval_branches env locals brs x with
257
	  | Value.Absent ->
258
	      let x = match x with
259
		| Value.Xml (tag, attr, child,sigma) ->
260
		    let child = eval_xtrans env locals brs child in
261 262
		    Value.Xml (tag, attr, child,sigma)
		| Value.XmlNs (tag, attr, child, ns,sigma) ->
263
		    let child = eval_xtrans env locals brs child in
264
		    Value.XmlNs (tag, attr, child, ns,sigma)
265
		| x -> x in
266
	      let acc' = Value.Pair (x, Absent,sigma) in
267 268 269 270
	      set_cdr acc acc';
	      acc'
	  | x -> append_cdr acc x
      in
271
      eval_xtrans_aux env locals brs acc y
272 273 274
  | _ -> acc

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

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

284 285 286 287 288 289 290 291
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
Pietro Abate's avatar
Pietro Abate committed
292
      (* XXX Env.empty ??? *)
293
      let (_, bindings) = Run_dispatch.run_dispatcher [||] disp v in
294 295 296 297 298 299 300 301
      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

302
let eval_toplevel items =
303 304 305 306
  let n = !nglobs in
  try List.iter eval_toplevel items
  with exn -> nglobs := n; raise exn

307
let eval_var v =
308 309 310 311 312 313 314 315
  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
Pietro Abate's avatar
Pietro Abate committed
316
      (* XXX Env.empty ??? *)
317
      let (_, bindings) = Run_dispatch.run_dispatcher [||] disp v in
318 319 320 321 322 323 324
      Array.blit bindings 0 globs !nglobs n;
      nglobs := !nglobs + n
  | LetDecl (e,lsize) ->
      let v = expr e lsize in
      globs.(!nglobs) <- v;
      incr nglobs

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